[blackeangel]

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