Export data from Excel to Access Table (ADO) using VBA

**Admin** · 10-14-2011, 08:25 AM

Hi All.

If you want to export a range of data into an Access table (Either before or 2007 or Post 2007), here is a sub. This also allows you to either create a new table or append an existing table.

Code:

Option Explicit

Public Enum TableProperty
    AppendTable = 0
    CreateTable = 1
End Enum

Private Const strTitle As String = "ExcelFox.com"

Sub ExportRangeIntoAccess(ByVal DB_FilePath As String, ByVal DB_Name As String, _
                                                    ByVal Tbl_Name As String, _
                                                    ByVal xl_SheetName As String, _
                                                    ByVal HeaderYes As Boolean, _
                                                    ByVal TableProp As TableProperty, _
                                        Optional ByVal RangeAddress As String, _
                                        Optional ByVal DefinedRngName As String, _
                                        Optional ByVal ClearTable As Boolean = True)
    
    Dim adoConn             As Object
    Dim wbkActive           As Workbook
    Dim wbkTemp             As Workbook
    Dim wksSource           As Worksheet
    Dim wksTemp             As Worksheet
    Dim rngFirstCell        As Range
    Dim strAddress          As String
    Dim strDataRange        As String
    Dim arrNameRanges()     As String
    Dim strTempFPath        As String
    Dim strTempFullName     As String
    Dim strDBFullName       As String
    Dim strExtn             As String
    Dim Hdr                 As Variant
    Dim lngLoop             As Long
    Dim lngStartRow         As Long
    Dim lngEndRow           As Long
    Dim lngRowsSoFar        As Long
    Dim lngLastCol          As Long
    Dim lngLastRow          As Long
    Dim lngSU               As Long
    Dim Flg                 As Boolean
    Dim rngBlank            As Range
            
    With Application
        lngSU = .ScreenUpdating
        .EnableEvents = 0
        .ScreenUpdating = 0
        .DisplayAlerts = 0
    End With
    
    
    Const RowsBlock         As Long = 50000
    
    If Right$(DB_FilePath, 1) <> Application.PathSeparator Then DB_FilePath = DB_FilePath & Application.PathSeparator
    
    strExtn = LCase$(Right$(DB_Name, 4))
    
    If strExtn = ".mdb" Then Flg = True
    
    If Not Flg Then
        strExtn = LCase$(Right$(DB_Name, 6))
        If strExtn <> ".accdb" Then
            MsgBox "Not a valid extension", vbCritical, strTitle
            GoTo QuickExit
        End If
    End If
    
    strDBFullName = DB_FilePath & DB_Name
    
    If Not IsFileExists(strDBFullName) Then
        MsgBox "DB " & strDBFullName & " doesn't exists", vbCritical, strTitle
        GoTo QuickExit
    End If
    
    Set wbkActive = ThisWorkbook
    strTempFPath = wbkActive.Path
                
    If strTempFPath = vbNullString Then
        strTempFPath = Environ$("Temp") & Application.PathSeparator
    End If
                
    On Error Resume Next
    Set wksSource = wbkActive.Worksheets(CStr(xl_SheetName))
    If Err.Number <> 0 Then
        MsgBox "Worksheet '" & xl_SheetName & "' doesn't exists", vbInformation, strTitle
        Err.Clear: On Error GoTo 0
        GoTo QuickExit
    End If
    On Error GoTo 0
    
    If Len(Trim$(DefinedRngName)) Then
        If HeaderYes Then
            On Error Resume Next
            Set rngBlank = wbkActive.Worksheets(CStr(xl_SheetName)).Range(DefinedRngName).Rows("2:2").SpecialCells(4)
            On Error GoTo 0
        Else
            On Error Resume Next
            Set rngBlank = wbkActive.Worksheets(CStr(xl_SheetName)).Range(DefinedRngName).Rows("1:1").SpecialCells(4)
            On Error GoTo 0
        End If
        If Not rngBlank Is Nothing Then
            MsgBox "Range " & rngBlank.Address(0, 0) & vbLf & "Seem to be empty. It should not be empty", vbCritical, strTitle
            GoTo QuickExit
        End If
        strDataRange = DefinedRngName
        lngLastRow = Split(wbkActive.Worksheets(CStr(xl_SheetName)).Range(strDataRange).Address, "$")(4)
    ElseIf Len(Trim$(RangeAddress)) Then
        If HeaderYes Then
            On Error Resume Next
            Set rngBlank = wbkActive.Worksheets(CStr(xl_SheetName)).Range(RangeAddress).Rows("2:2").SpecialCells(4)
            On Error GoTo 0
        Else
            On Error Resume Next
            Set rngBlank = wbkActive.Worksheets(CStr(xl_SheetName)).Range(RangeAddress).Rows("1:1").SpecialCells(4)
            On Error GoTo 0
        End If
        If Not rngBlank Is Nothing Then
            MsgBox "Range " & rngBlank.Address(0, 0) & vbLf & "Seem to be empty. It should not be empty", vbCritical, strTitle
            GoTo QuickExit
        End If
        strDataRange = RangeAddress
        lngLastRow = Split(wbkActive.Worksheets(CStr(xl_SheetName)).Range(strDataRange).Address, "$")(4)
    Else
        With wksSource
            lngLastRow = .Cells.Find(What:="*", after:=.Cells(1), lookat:=2, SearchOrder:=1, SearchDirection:=2).Row
            lngLastCol = .Cells.Find(What:="*", after:=.Cells(1), lookat:=2, SearchOrder:=2, SearchDirection:=2).Column
            Set rngFirstCell = .Cells.Find(What:="*", after:=.Cells(lngLastRow, lngLastCol), lookat:=2)
            strAddress = rngFirstCell.CurrentRegion.Address
            If InStr(1, strAddress, ":") = 0 Then
                MsgBox "There is no data to be exported", vbCritical, "KnowledgeMine"
                GoTo QuickExit
            End If
            lngLastCol = Range(CStr(Split(strAddress, ":")(1))).Column
            lngLastRow = CLng(Split(strAddress, "$")(4))
            .Range(rngFirstCell, .Cells(lngLastRow, lngLastCol)).Name = "DB_Range"
            strDataRange = "DB_Range"
            If HeaderYes Then
                On Error Resume Next
                Set rngBlank = wbkActive.Worksheets(CStr(xl_SheetName)).Range(strDataRange).Rows("2:2").SpecialCells(4)
                On Error GoTo 0
            Else
                On Error Resume Next
                Set rngBlank = wbkActive.Worksheets(CStr(xl_SheetName)).Range(strDataRange).Rows("1:1").SpecialCells(4)
                On Error GoTo 0
            End If
            If Not rngBlank Is Nothing Then
                MsgBox "Range " & rngBlank.Address(0, 0) & vbLf & "Seem to be empty. It should not be empty", vbCritical, strTitle
                GoTo QuickExit
            End If
        End With
    End If
    
    Set rngFirstCell = Nothing
    Hdr = wksSource.Range(CStr(strDataRange)).Rows(1)
    
    Set wbkTemp = Workbooks.Add
    
    If lngLastRow > 65535 Then
        With wksSource
            For lngLoop = 1 To 1 + (lngLastRow \ RowsBlock)
                ReDim Preserve arrNameRanges(1 To lngLoop)
                If lngLoop = 1 Then
                    lngEndRow = RowsBlock
                    lngStartRow = 1
                    lngRowsSoFar = RowsBlock
                    Set wksTemp = Nothing
                    Set wksTemp = wbkTemp.Worksheets.Add
                    .Range(.Cells(1), .Cells(lngEndRow, UBound(Hdr, 2))).Copy wksTemp.Range("a1")
                    wksTemp.UsedRange.Name = "Temp" & lngLoop
                    arrNameRanges(lngLoop) = "Temp" & lngLoop
                Else
                    Set wksTemp = Nothing
                    Set wksTemp = wbkTemp.Worksheets.Add
                    lngStartRow = lngEndRow + 1
                    lngEndRow = Application.Min(RowsBlock, lngLastRow - lngEndRow)
                    lngEndRow = lngStartRow + lngEndRow
                    wksTemp.Range("a1").Resize(, UBound(Hdr, 2)).Value = Hdr
                    .Range(.Cells(lngStartRow, 1), .Cells(lngEndRow, UBound(Hdr, 2))).Copy wksTemp.Range("a2")
                    wksTemp.UsedRange.Name = "Temp" & lngLoop
                    arrNameRanges(lngLoop) = "Temp" & lngLoop
                End If
            Next
        End With
    Else
        ReDim Preserve arrNameRanges(1 To 1)
        arrNameRanges(1) = "Temp1"
        wksSource.Range(CStr(strDataRange)).Copy wbkTemp.Worksheets(1).Range("a1")
        wbkTemp.Worksheets(1).UsedRange.Name = arrNameRanges(1)
    End If
    
    wbkTemp.SaveAs strTempFPath & "_Temp_", 56 'xls
    strTempFullName = wbkTemp.FullName
    wbkTemp.Close 0
    Set wbkTemp = Nothing
    
    Set adoConn = CreateObject("ADODB.Connection")
        
    If Flg Then
        adoConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;data source=" & CStr(strDBFullName) & ";"
    Else
        adoConn.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & CStr(strDBFullName) & ";"
    End If
    
    
    If TableProp = AppendTable Then
        If ClearTable Then
            On Error Resume Next
            adoConn.Execute "DELETE * FROM " & Tbl_Name
            On Error GoTo 0
        End If
    End If
    
    For lngLoop = 1 To UBound(arrNameRanges)
        If lngLoop = 1 Then
            If TableProp = AppendTable Then
                If Flg Then
                    If HeaderYes Then
                        adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 8.0;HDR=Yes;]"
                    Else
                        adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 8.0;HDR=No;]"
                    End If
                Else
                    If HeaderYes Then
                        adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 12.0;HDR=Yes;]"
                    Else
                        adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 12.0;HDR=No;]"
                    End If
                End If
            Else
                If Flg Then
                    On Error Resume Next
                    adoConn.Execute "DROP Table " & Tbl_Name
                    On Error GoTo 0
                    If HeaderYes Then
                        adoConn.Execute "SELECT * INTO " & Tbl_Name & " FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 8.0;HDR=Yes;]"
                    Else
                        adoConn.Execute "SELECT * INTO " & Tbl_Name & " FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 8.0;HDR=No;IMEX=1]"
                    End If
                Else
                    On Error Resume Next
                    adoConn.Execute "DROP Table " & Tbl_Name
                    On Error GoTo 0
                    If HeaderYes Then
                        adoConn.Execute "SELECT * INTO " & Tbl_Name & " FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 12.0;HDR=Yes;]"
                    Else
                        adoConn.Execute "SELECT * INTO " & Tbl_Name & " FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 12.0;HDR=No;IMEX=1;]"
                    End If
                End If
            End If
        Else
            If Flg Then
                If HeaderYes Then
                    adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 8.0;HDR=Yes;]"
                Else
                    adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 8.0;HDR=No;]"
                End If
            Else
                If HeaderYes Then
                    adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 12.0;HDR=Yes;]"
                Else
                    adoConn.Execute "INSERT INTO " & CStr(Tbl_Name) & " SELECT * FROM [" & arrNameRanges(lngLoop) & "] IN '" & strTempFullName & "'[Excel 12.0;HDR=No;]"
                End If
            End If
        End If
    Next
    
    Kill strTempFullName
    
    If adoConn.State <> 0 Then adoConn.Close
    Set adoConn = Nothing
    Set wbkActive = Nothing
    Set wksSource = Nothing
    
QuickExit:
    If Err.Number <> 0 Then
        Err.Clear: On Error GoTo 0
    End If
    With Application
        .EnableEvents = 1
        .ScreenUpdating = lngSU
        .DisplayAlerts = 1
    End With
    
End Sub

Function IsFileExists(ByVal FilePath As String) As Boolean
    IsFileExists = Len(Dir(FilePath, vbDirectory))
End Function

and call the sub like

Code:

Sub kTest()
    
    ExportRangeIntoAccess "C:\ExcelFox", "Test_2007.accdb", "MyTable", "Sheet1", True, CreateTable, "A1:K200000", "", False
    
    'ExportRangeIntoAccess "C:\ExcelFox", "Test_2007.accdb", "MyTable", "Sheet1", True, CreateTable, "MyRange", "", False
    'ExportRangeIntoAccess "C:\ExcelFox", "Test_2007.accdb", "MyTable", "Sheet1", True, AppendTable, "A1:K200000", "", True
    'ExportRangeIntoAccess "C:\ExcelFox", "Test_2003.mdb", "MyTable", "Sheet1", True, AppendTable, "A1:K20000", "", True
    'ExportRangeIntoAccess "C:\ExcelFox", "Test_2003.mdb", "MyTable", "Sheet1", True, CreateTable, "A1:K20000", "", False
    
End Sub

Enjoy !