Export Range From Excel To Access

[goss]

Hi all,

Using Office 2010
I am trying to export 100,003 records from Excel to Access

Setup:
Using NWind.mdb, added table named tblTransactions
Trying to use ACE driver instead of JET
Downloaded and installed 32Bit ACE to coincide with by veriosn of Office
I found some code on Ken Puls site and am trying to modify to suit.
I set reference to ADO 2.5.
It appears the dynamic name ranges are correct
The path to the database is correct
The name of the table is correct
The names of the fields in the table match between the Access table and the Excel table
The error handler is returning Err.number 0 but I am not sure why?

Thanks.

Option Explicit
 
Sub DB_Insert_via_ADOSQL()
    'Author: Ken Puls
    'Date: 12/20/2004
    'Purpose: Export range of Excel To MSAccess
    'Links: -> http://www.excelguru.ca/node/18

    'Modified by: goss
    'Modified Date: 07/31/2011

    'References: (From VBE, Tools..References)
       'Microsoft ActiveX Data Objects Libary

    Dim cn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim dbPath As String
    Dim tblName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rngColHeads As Range
    Dim rngTblRcds As Range
    Dim colHead As String
    Dim rcdDetail As String
    Dim strStart As String
    Dim strEnd As String
    Dim ch As Integer
    Dim cl As Integer
    Dim intRowHeader As Integer
    Dim lngCols As Long
    Dim lngRows As Long
    Dim notNull As Boolean
    Dim n As Name

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Data")

    'Database path ex: C:\Users\goss\Documents\Databases\Nwind.mdb
    dbPath = ws.Range("B1").Value
    
    'Table to append records to ex: tblTransactions
    tblName = ws.Range("B2").Value

    'Last row on ws (Assumes data in Col A)
    lngRows = ws.Cells(Rows.Count, 1).End(xlUp).Row

    'Last column on ws(Assumes header in row 3)
    With ws
      lngCols = .Cells(3, .Columns.Count).End(xlToLeft).Column
    End With

    'Add dynamic named range for headers
        With ws
            strStart = .Cells(3, 1).Address 'Assumes header begins at A3
            strEnd = .Cells(3, lngCols).Address
        End With

        wb.Names.Add Name:="lstHeadings", RefersTo:= _
            "=" & strStart & ":" & strEnd

    'Add dynamic named range for records <- Update "E" below for your last column
        With ws
            strStart = .Cells(4, 1).Address 'Assumes data begins at A4
            strEnd = .Cells(lngRows, lngCols).Address
        End With

        wb.Names.Add Name:="tblRecords", RefersTo:= _
            "=" & strStart & ":" & strEnd
            
    Set rngColHeads = ws.Range("lstHeadings")
    Set rngTblRcds = ws.Range("tblRecords")

    'Concatenate a string with the names of the column headings
    colHead = " ("
    For ch = 1 To rngColHeads.Count
        colHead = colHead & rngColHeads.Columns(ch).Value
        Select Case ch
            Case Is = rngColHeads.Count
                colHead = colHead & ")"
            Case Else
                colHead = colHead & ","
        End Select
    Next ch

    'Create ADO connection to current workbook
    'Uses ACE Driver Not JET
     
     Set cn = New ADODB.Connection
     With cn
        .Provider = "Microsoft.ACE.OLEDB.12.0;"
        .ConnectionString = "Data Source=""" & wb.FullName & """;Extended Properties=Excel 12.0;"
        .Open
     End With

    'Begin transaction processing
    On Error GoTo EndUpdate
    cn.BeginTrans

    'Insert records into database from worksheet table
    For cl = 1 To rngTblRcds.Rows.Count

        'Assume record is completely Null, and open record string for concatenation
        notNull = False
        rcdDetail = "('"

        'Evaluate field in the record
        For ch = 1 To rngColHeads.Count
            Select Case rngTblRcds.Rows(cl).Columns(ch).Value
                    'if empty, append value of null to string
                Case Is = Empty
                    Select Case ch
                        Case Is = rngColHeads.Count
                            rcdDetail = Left(rcdDetail, Len(rcdDetail) - 1) & "NULL)"
                        Case Else
                            rcdDetail = Left(rcdDetail, Len(rcdDetail) - 1) & "NULL,'"
                    End Select

                    'if not empty, set notNull to true, and append value to string
                Case Else
                    notNull = True
                    Select Case ch
                        Case Is = rngColHeads.Count
                            rcdDetail = rcdDetail & rngTblRcds.Rows(cl).Columns(ch).Value & "')"
                        Case Else
                            rcdDetail = rcdDetail & rngTblRcds.Rows(cl).Columns(ch).Value & "','"
                    End Select
            End Select
        Next ch

        'If record consists of only Null values, do not insert it to table, otherwise
        'insert the record
        Select Case notNull
            Case Is = True
                rst.Open "INSERT INTO " & tblName & colHead & " VALUES " & rcdDetail, cn
            Case Is = False
                'do not insert record
        End Select
    Next cl

EndUpdate:
    'Check if error was encounted
    If Err.Number <> 0 Then
        'Error encountered.  Rollback transaction and inform user
        On Error Resume Next
        cn.RollbackTrans
        MsgBox "Error # " & Err.Number & " Update was not succesful!", vbCritical, "Error!"
    Else
        On Error Resume Next
        cn.CommitTrans
    End If

    'Tidy up
    cn.Close
    Set rst = Nothing
    Set cn = Nothing
    For Each n In wb.Names
        n.Delete
    Next n
    Set wb = Nothing
    Set ws = Nothing
    On Error GoTo 0
End Sub