Results 1 to 5 of 5

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

Hybrid View

Previous Post Previous Post   Next Post Next Post
  1. #1
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10

    Lightbulb 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 !
    Last edited by Admin; 03-18-2014 at 11:45 AM.
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

  2. #2
    Junior Member
    Join Date
    Sep 2011
    Posts
    8
    Rep Power
    0

    Smile Thanks...

    :o

  3. #3
    Junior Member
    Join Date
    Apr 2014
    Posts
    1
    Rep Power
    0

    Arrow

    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!

  4. #4
    Junior Member
    Join Date
    Aug 2014
    Posts
    4
    Rep Power
    0
    Hello, you can find information about your problem here Insert, change, or delete a Memo field - Access, hope help you.

  5. #5
    Junior Member
    Join Date
    Aug 2012
    Posts
    1
    Rep Power
    0
    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!

Similar Threads

  1. Delete Double Entry From Access DBF Table
    By MASIF in forum Access Help
    Replies: 1
    Last Post: 03-07-2013, 11:40 AM
  2. Replies: 3
    Last Post: 03-05-2013, 03:57 PM
  3. Delete Duplicate Records from Access Table
    By littleiitin in forum Access Help
    Replies: 7
    Last Post: 08-23-2012, 10:30 AM
  4. Upload Excel Data to SQL Table
    By littleiitin in forum Excel and VBA Tips and Tricks
    Replies: 3
    Last Post: 08-22-2012, 11:02 AM
  5. Checking Table Exist in Access Database or Not
    By littleiitin in forum Excel and VBA Tips and Tricks
    Replies: 1
    Last Post: 11-16-2011, 04:32 PM

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •