Export Excel Range to Access

Vishesh's picture
'Following is a very simple piece of code to Export an Excel range to Access.
'Run the procedure ExportToAccess. Copy the complete code given below:

Option Explicit
'Goto Menu - Tools->References and add reference to Microsoft ActiveX Data Objects 2.x Library

Dim objConnection As ADODB.Connection
Sub ConnectToDatabase(strDBpath As String)
    Set objConnection = New ADODB.Connection
    objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
    "Data Source=" & strDBpath
End Sub
Sub ExportToAccess(rngData As Range, Optional blnHeader As Boolean = False)
    Dim rstTable        As ADODB.Recordset
    Dim lngRow          As Long
    Dim lngCol          As Long
    Dim strDB           As String
    Dim strTable        As String
    Dim intStartRow     As Integer
    If blnHeader = False Then
        intStartRow = 1
        intStartRow = 2
    End If
'---------------------User Inputs-------------------------------
'Provide database path
    strDB = "C:\ABC\Temp.mdb"
'Provide SQL Query or Table name from database
    strTable = "Employee"
'Establish Database connection
On Error GoTo ErrH
    Call ConnectToDatabase(strDB)
    Set rstTable = New ADODB.Recordset
    rstTable.Open strTable, objConnection, adOpenKeyset, adLockOptimistic, adCmdTable
'Check if No of data columns are same as No. of fields in database
    If rngData.Columns.Count <> rstTable.Fields.Count Then
        MsgBox "No. of columns in data is different from no. of fields in DB table", vbCritical, "Export Error"
        GoTo ExitH
    End If
    For lngRow = intStartRow To rngData.Rows.Count
        With rstTable
            For lngCol = 0 To (.Fields.Count - 1)
                .Fields(lngCol) = rngData.Cells(lngRow, lngCol + 1).Value
            Next lngCol
        End With
    Next lngRow
On Error GoTo 0
    GoTo ExitH
    If objConnection.State = 1 Then rstTable.CancelUpdate
    MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, "Export Error"
    If objConnection.State = 1 Then rstTable.Close
    Set rstTable = Nothing
End Sub
Sub CloseDB()
    Set objConnection = Nothing
End Sub