Iska,
Код:
Sub ExceltoAccessList()
Worktable = CreateObject("WScript.Shell").SpecialFolders("Desktop")
BaseName = Worktable & "\" & ActiveWorkbook.Name & ".mdb"
tmppath = Environ("TEMP")
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")
Set fso = CreateObject("Scripting.FileSystemObject")
If Err.Number = 429 Then
On Error GoTo 0
If fso.FileExists(BaseName) Then fso.DeleteFile BaseName, True
If fso.FileExists(tmppath & "\" & ActiveWorkbook.Name) Then fso.DeleteFile tmppath & "\" & ActiveWorkbook.Name, True
ActiveWorkbook.SaveCopyAs tmppath & "\" & ActiveWorkbook.Name
Set Catalog = CreateObject("ADOX.Catalog")
Catalog.Create dbConnectStr
Set Catalog = Nothing
Set cnt = New ADODB.Connection
cnt.Open dbConnectStr
sSQL = "SELECT * INTO [" & ActiveSheet.Name & "] FROM [Excel 12.0;HDR=YES;IMEX=1;DATABASE=" & tmppath & "\" & ActiveWorkbook.Name & "].[" & ActiveSheet.Name & "$]"
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 fso.FileExists(tmppath & "\" & ActiveWorkbook.Name) Then fso.DeleteFile tmppath & "\" & ActiveWorkbook.Name, True
ActiveWorkbook.SaveCopyAs tmppath & "\" & ActiveWorkbook.Name
If Err.Number = 91 Then
On Error GoTo 0
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(BaseName) Then fso.DeleteFile BaseName, True
Set Catalog = CreateObject("ADOX.Catalog")
Catalog.Create dbConnectStr
Set Catalog = Nothing
Set oAccess = GetObject(, "Access.Application")
oAccess.OpenCurrentDataBase (BaseName)
End If
On Error GoTo 0
oAccess.CurrentProject.Connection.Execute "SELECT * INTO [" & ActiveSheet.Name & "] FROM [Excel 12.0;HDR=YES;IMEX=1;DATABASE=" & tmppath & "\" & ActiveWorkbook.Name & "].[" & ActiveSheet.Name & "$]"
oAccess.RefreshDataBaseWindow
End If
If fso.FileExists(tmppath & "\" & ActiveWorkbook.Name) Then fso.DeleteFile tmppath & "\" & ActiveWorkbook.Name, True
End Sub
Хранится в надстройке
Вызывается кнопкой надстройки
Ошибка в строке
SELECT * INTO [" & ActiveSheet.Name & "] FROM [Excel 12.0;HDR=YES;IMEX=1;DATABASE=" & tmppath & "\" & ActiveWorkbook.Name & "].[" & ActiveSheet.Name & "$]"
Текст ошибки примерно такой - лист2$ недопустимое имя. Назовите по другому или убедитесь что оно есть.
Если файл из почты сохранить в другое место, всё работает без проблем. Но, тк это правленый вариант, то этой ошибки вы не увидите.
Ошибка была когда вместо tmppath & "\" & ActiveWorkbook.Name было ActiveWorkbook.FullName
