ERLANDSEN DATA CONSULTING Excel & VBA Tips   Informasjon på norsk / Information in Norwegian

These pages are no longer updated and are only available for archive purposes.

Click here to visit the pages with updated information.

Export data from Excel to Access (ADO)

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 example 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 Microsoft ActiveX Data Objects x.x Object Library.
Use ADO if you can choose between ADO and DAO for data import or export.

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

 

Document last updated 2005-02-01 20:32:10      Printerfriendly version

User comments:
Ole P. from Norway wrote (2005-09-19 23:39:45 CET):
Re: Error with updating
The .Update command is probably failing because you don't have write access to the database table.
Run the code again and enter Debug mode when the macro stops.
Open the Immediate window (ctrl+g), write this and press enter to see a detailed error description:
? Err.Description
Penina Smith from London wrote (2005-09-19 11:40:16 CET):
Error with updating
For me everything works fine up to the point

.Update

above..where i get the error Run-time error '-214721..': Automation Error.

Any ideas? Thanks..
Ole P. from Norway wrote (2005-08-04 00:08:23 CET):
Re: Problem! - Automation Error (Run-time error - 2147217843) upon trying this
Please use the public Excel newsgroups if you are looking for free support to debug your code.
LevelThought wrote (2005-08-03 23:20:25 CET):
Problem! - Automation Error (Run-time error - 2147217843) upon trying this
Upon trying the code below, I keep receiving an automation error. Any insight as to the cause of the problem and a resolution?

Thanks much for any assistance.

[snip]
Ole P. from Norway wrote (2005-06-03 14:10:53 CET):
Re: Its not updating
Please use the public Excel newsgroups if you are looking for free support to debug your code.
JonnyNeedsHelp from tbay.on.ca wrote (2005-06-02 21:43:16 CET):
Its not updating
Hello, I was wondering if someone could help me get this code to update the field info.

[snip]
Ole P. from Norway wrote (2005-04-28 09:51:12 CET):
Re: Error 3704: Operation Not Allowed when Object is Closed
The exampleprocedure above doesn't contain any error trapping.
You will have to add this yourself to handle situations where the macro tries to close connections or recordsets that is no longer open.

E.g. like this:
On Error Resume Next
cn.Close
On Error Goto 0
Geo from Los Angeles wrote (2005-04-28 02:42:52 CET):
Error 3704: Operation Not Allowed when Object is Closed
I get this error when I run the ADOFromExcelToAccess() subroutine.

Error 3704: Operation Not Allowed when Object is Closed

I've tried commenting out the close connection statements as well as setting the connections to null, but not dice... Any help is greatly appreciated.

By the way: I've referenced Microsoft ActiveX Data Objects 2.7 Library
TonyTheGRRReat from Michigan, USA wrote (2005-03-04 19:51:08 CET):
Re: Re: Either adding new OR updating existing
That was exactly what I was thinking, but I was too lazy to do it on my own. I appreciate the help. Thank you very much.
Ole P. from Norway wrote (2005-03-04 18:44:01 CET):
Re: Either adding new OR updating existing
You can do this in several ways.
One alternative is like this:

With rs
  strSQL = "select * from TableName where FieldName1 = 'Item1'"
    On Error Resume Next
    .Open strSQL, cn, adOpenKeyset, adLockOptimistic, adCmdText
    On Error GoTo 0
    If .State = adStateOpen Then ' successfully opened the recordset
        If .EOF Then ' no records returned
        .AddNew ' create a new record
        .Fields(0).Value = "Item1"
        .Fields(1).Value = "NewItemContent"
        .Fields(2).Value = "NewItemContent"
        .Update ' stores the new record
    Else ' one (or more records returned)
        ' edit existing record
        .Fields(1).Value = "NewItemContent"
        .Fields(2).Value = "NewItemContent"
        .Update ' stores the new record
    End If
    .Close ' close the recordset
    End If
End With
Set rs = Nothing


 

Erlandsen Data Consulting     http://www.erlandsendata.no/   
Excel & VBA Tips   Copyright ©1999-2017    Ole P. Erlandsen   All rights reserved
E-mail Contact Address