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

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 !

:o

hi, I am new to excel vba programming, I used your code to export data from excel to access 2007, works perfectly, except for one problem. if the excel column has more than 255 characters in the rows, then I am getting error "too much data", since the default property for access columns is 'text', how to modify your code to be able to change property to 'memo' if length of data is more than 255? Thanks!

Hello, you can find information about your problem here Insert, change, or delete a Memo field - Access, hope help you.

Hi. I'm not an expert on VBA, I couldn't figure out how "HeaderYes" is determined in above codes. It seems that the codes determine the first row of selected range as HDR, then how does the code determine if the first row is header row or not? I'd appreciate if you point it out. Thanks in advance!