Export data from Excel to Access (ADO)
2005-02-01 ADO 4 326
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 SubThe 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