Shocker.Pro, в общем с вашими советами накуролесил такое:
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
Sub ExceltoAccess()
Worktable = CreateObject("WScript.Shell").SpecialFolders("Desktop")
BaseName = Worktable & "\" & ActiveWorkbook.Name & ".mdb"
Select Case CLng(Split(Application.Version, ".")(0))
Case Is < 12
dbConnectStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & BaseName & ";"
Case Is >= 12
dbConnectStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & BaseName & ";"
End Select
On Error Resume Next
Set oAccess = GetObject(, "Access.Application")
If Err.Number = 429 Then
Set Catalog = CreateObject("ADOX.Catalog")
Catalog.Create dbConnectStr
Set Catalog = Nothing
Set cnt = New ADODB.Connection
cnt.Open dbConnectStr
Set rs = CreateObject("ADODB.Recordset")
sSQL = "SELECT * INTO [" & ActiveSheet.Name & "] FROM [Excel 12.0;HDR=YES;IMEX=1;DATABASE=" & ActiveWorkbook.FullName & "].[" & ActiveSheet.Name & "$]"
Set rs = cnt.Execute(sSQL)
cnt.Close
Set sAccess = CreateObject("Access.Application")
sAccess.Visible = True
sAccess.UserControl = True
sAccess.OpenCurrentDataBase (BaseName)
Else
basepath = oAccess.CurrentDb.Name
If Err.Number = 91 Then
Set Catalog = CreateObject("ADOX.Catalog")
Catalog.Create dbConnectStr
Set Catalog = Nothing
Set sAccess = GetObject(, "Access.Application")
sAccess.OpenCurrentDataBase (BaseName)
End If
oAccess.CurrentProject.Connection.Execute "SELECT * INTO [" & ActiveSheet.Name & "] FROM [Excel 12.0;HDR=YES;IMEX=1;DATABASE=" & ActiveWorkbook.FullName & "].[" & ActiveSheet.Name & "$]"
End If
Err.Clear
End Sub
Есть недостаток, после загрузки в БД таблица в Access не отображается. Но если закрыть и открыть БД, то все появляется. Как это исправить?
