DRAFT de um excel que criei para uns testes na Orange:
Sub AccImport(ByRef ws As Worksheet)
Dim acc As New Access.Application
Dim bla As String
Dim rng As Range
Dim path As String
Dim dbName As String
Dim wb As Workbook
path = "C:\Users\pmendes\Local documents\"
dbName = "QVT_prod_cat.accdb"
On Error Resume Next
acc.NewCurrentDatabase path & dbName, acNewDatabaseFormatUserDefault
acc.CloseCurrentDatabase
On Error GoTo 0
acc.OpenCurrentDatabase path & dbName
Application.StatusBar = "Exporting " & ws.Name & ". PLEASE WAIT!"
Set wb = Application.ActiveWorkbook
Application.DisplayAlerts = False
On Error Resume Next
Application.Workbooks("##expt##" & ws.Name & "##.xlsx").Close
On Error GoTo 0
Application.ActiveWorkbook.SaveAs path & "##expt##" & ws.Name & "##.xlsx"
Application.DisplayAlerts = True
wb.Activate
Application.Worksheets(ws.Name).Activate
On Error Resume Next
acc.DoCmd.DeleteObject acTable, Application.ActiveWorkbook.ActiveSheet.Name
If Err.Number > 0 And Err.Number <> 7874 Then
MsgBox Err.Description, vbCritical, "MS Access Error"
Exit Sub
End If
On Error GoTo 0
acc.DoCmd.TransferSpreadsheet _
acImport, _
acSpreadsheetTypeExcel12Xml, _
Application.ActiveWorkbook.ActiveSheet.Name, _
Application.ActiveWorkbook.FullName, _
True
acc.CloseCurrentDatabase
acc.Quit
Set acc = Nothing
Application.ActiveWorkbook.Close
Application.StatusBar = "Done exporting"
End Sub
