Export data from Excel to Access (ADO)

 2005-02-01    Import & Export    4    110

If you want to export data to an Access table from an Excel worksheet, the macro example below shows how this can be done:

Sub ADOFromExcelToAccess()
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
    ' connect to the Access database
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\FolderName\DataBaseName.mdb;"
    ' open a recordset
    Set rs = New ADODB.Recordset
    rs.Open "TableName", cn, adOpenKeyset, adLockOptimistic, adCmdTable  
    ' all records in a table
    r = 3 ' the start row in the worksheet
    Do While Len(Range("A" & r).Formula) > 0 
    ' repeat until first empty cell in column A
        With rs
            .AddNew ' create a new record
            ' add values to each field in the record
            .Fields("FieldName1") = Range("A" & r).Value
            .Fields("FieldName2") = Range("B" & r).Value
            .Fields("FieldNameN") = Range("C" & r).Value
            ' add more fields if necessary...
            .Update ' stores the new record
        End With
        r = r + 1 ' next row
    Loop
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
End Sub
The macro examples assumes that your VBA project has added a reference to the ADO object library. You can do this from within the VBE by selecting the menu Tools, References... and selecting the Microsoft ActiveX Data Objects x.x Object Library.

Below is an extended example that shows how you can export data from multiple workbooks:

Sub ExportMultipleFiles()
Dim fn As Variant, f As Integer
Dim cn As ADODB.Connection
    ' select one or more files
    fn = Application.GetOpenFilename("Excel-files,*.xls", 1, "Select One Or More Files To Open", , True)
    If TypeName(fn) = "Boolean" Then Exit Sub
    ' connect to the Access database
    Set cn = New ADODB.Connection
    On Error GoTo DisplayErrorMessage
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\FolderName\DataBaseName.mdb;"
    On Error GoTo 0
    If cn.State <> adStateOpen Then
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    ' repeat for each selected file
    For f = LBound(fn) To UBound(fn)
        Debug.Print "Selected file #" & f & ": " & fn(f)
        Application.StatusBar = "Exporting data from " & fn(f) & "..."
        ExportFromExcelToAccess cn, CStr(fn(f))
        Application.StatusBar = False
    Next f
    Application.ScreenUpdating = True
    ' close the database connection
    cn.Close
    Set cn = Nothing
    MsgBox "The data export has finished!", vbInformation, ThisWorkbook.Name
    Exit Sub

DisplayErrorMessage:
    MsgBox Err.Description, vbExclamation, ThisWorkbook.Name
    Resume Next
End Sub

Sub ExportFromExcelToAccess(cn As ADODB.Connection, strFullFileName As String)
' exports data from a workbook to a table in an Access database
' this procedure must be edited before use
Dim wb As Workbook, rs As ADODB.Recordset, r As Long, f As Integer
    If cn Is Nothing Then Exit Sub
    If cn.State <> adStateOpen Then Exit Sub
    
    ' open the source workbook
    On Error GoTo DisplayErrorMessage
    Set wb = Workbooks.Open(strFullFileName, True, True)
    On Error GoTo 0
    If wb Is Nothing Then Exit Sub ' failed to open the workbook
    
    ' activate the proper data source worksheet
    wb.Worksheets(1).Activate
    
    ' create a new recordset
    Set rs = New ADODB.Recordset
    ' open a recordset, all records in a table
    On Error GoTo DisplayErrorMessage
    rs.Open "TableName", cn, adOpenKeyset, adLockOptimistic, adCmdTable
    ' or open an empty recordset using a sql query that returns no records
    'rs.Open "select * from TableName where SomeFieldName = -1", 
    'cn, adOpenKeyset, adLockOptimistic, adCmdText
    On Error GoTo 0
    If rs.State = adStateOpen Then ' successfully opened the recordset
        r = 2 ' the first row containing data in the worksheet
        Do While Len(Range("A" & r).Formula) > 0
            ' repeat until the first empty cell in column A
            With rs
                .AddNew ' create a new record
                ' add values to each field in the record
                For f = 1 To .Fields.Count
                    .Fields(f - 1).Value = Cells(r, f).Value
                Next f
                .Update ' stores the new record
            End With
            r = r + 1 ' next row
        Loop
        rs.Close
    End If
    Set rs = Nothing
    
    ' close the source workbook without saving any changes
    wb.Close False
    Exit Sub
    
DisplayErrorMessage:
    MsgBox Err.Description, vbExclamation, ThisWorkbook.Name
    Resume Next
End Sub


Leave a comment:

Your comment will only be published after it has been moderated and found spam free.
Your e-mail address will only be used to display your Gravatar.

OPE | 2012-09-20 16:48:33 (GMT)

This will select all fields in a table:

rs.Open "select * from TableName", cn, adOpenKeyset, adLockOptimistic, adCmdText

Christian Høj | 2012-09-20 12:35:28 (GMT)

Hi.

Thanks. I have a problems with the original code "ADOFromExcelToAccess" it does not import the record number "ID" field wich is the primary key. Can you help changing the code, so it will import ALL Fields from the database to Excel?

Best regards
Christian

OPE | 2012-09-19 17:29:14 (GMT)

Hi!

The world moves slowly forward, so the connection strings might change since my original posts.

You can update records doing something like this:

' the variable named cn must be an open ADO connection
Set rs = New ADODB.Recordset ' open a recordset
With rs
.Open "TableName", cn, adOpenKeyset, adLockOptimistic, adCmdTable ' all records in a table
Do While Not .EOF
If .Fields("SomeFieldName").Value = "SomeCriteria" Then
.Fields("SomeOtherField").Value = Date ' change a record item
.Fields("Another Field").Value = "NewContent" ' change a record item
.Update ' save the changes
End If
.MoveNext
Loop
.Close
End With
Set rs = Nothing


Or like this:
' the variable named cn must be an open ADO connection
' build sql update command string
strSQL = "UPDATE TableName SET SomeOtherField = '" & Format(Date, "yyyy-mm-dd") & "',"
strSQL = strSQL & "[Another Field] = 'NewContent' WHERE SomeFieldName = 'SomeCriteria'"
' update one or more records (all that matches the WHERE filter in the sql command text)
cn.Execute strSQL, lngCount, adCmdText ' lngCount will return the number of updated records

Christian Høj | 2012-09-19 10:11:56 (GMT)

Hejsa.

Good writeup, I had to change "Provider=Microsoft.Jet.OLEDB.4.0" to "Provider=Microsoft.ACE.OLEDB.12.0" in order to get it working.

How would it be possible to update exsisting records in the database instead of adding new?

A reply would be VERY much appriciated

Best regards,
Christian