Export spreadsheet data to Access

Vishesh's picture

Following macro can be used in Excel VBA to export Excel data into Access.

Sub TestMacro()

Call ExcelToAccessTransferSpreadsheet("G:\ExcelExperts\ExcelAccessTest.mdb", "DBTestTbl", "G:\ExcelExperts\Test.xlsm", "Sheet1", "A1:C8")

End Sub

Sub ExcelToAccessTransferSpreadsheet(strDBPath As String, strDBTableName As String, strExcelFilePath As String, strSheet As String, strRange As String, Optional blnClearTableBfrUpload As Boolean = True, Optional blnDropTableBfrUpload As Boolean = False)

'Should have access on the system
'Creates a new table in Access if not found

Dim acc As Object

Set acc = CreateObject("Access.Application")

On Error GoTo DBErr
acc.OpenCurrentDatabase strDBPath
Err.Clear: On Error GoTo 0: On Error GoTo -1

If blnDropTableBfrUpload = True Then
On Error Resume Next
acc.DoCmd.RunSQL "Drop Table [" & strDBTableName & "]"
Err.Clear: On Error GoTo 0: On Error GoTo -1
Else
If blnClearTableBfrUpload = True Then
On Error Resume Next
acc.DoCmd.RunSQL "Delete * from [" & strDBTableName & "]"
Err.Clear: On Error GoTo 0: On Error GoTo -1
End If
End If
'acc.Visible = True
On Error GoTo ExcelErr
acc.DoCmd.TransferSpreadsheet _
TransferType:=0, _
SpreadSheetType:=10, _
TableName:=strDBTableName, _
Filename:=strExcelFilePath, _
HasFieldNames:=True, _
Range:=strSheet & "!" & strRange '"Sheet1$A1:B8"
Err.Clear: On Error GoTo 0: On Error GoTo -1

acc.CloseCurrentDatabase
acc.Quit

GoTo CleanUp

DBErr:
MsgBox Err.Number & "!" & Err.Description & vbLf & vbLf & "!! Should have MS Access install on your system !!", vbCritical, "DB Access Error"
GoTo CleanUp
ExcelErr:
MsgBox Err.Number & "!" & Err.Description, vbCritical, "Excel File Error"
GoTo CleanUp

CleanUp:
Set acc = Nothing

End Sub