Home Code

VBA > Excel automation > Import Worksheets and Append to Table in Access

VBA to loop and import Excel worksheets to an Access table

Many people have data for on separate sheets in Excel. Maybe each sheet is a day or month of activity. After accumulating a lot of data, there comes a time when it is nice to have everything in the same place. Then it can be summarized, sliced and diced, forecasted, charted, and more. This code opens an Excel file, loops through all of its sheets, unless you want to skip some, and writes data to a table in a database.

'*************** Code Start *****************************************************
' Purpose  : Loop and Import Excel spreadsheets to an Access table
' Author   : crystal (strive4peace) 
' License  : below code
' Code List: www.MsAccessGurus.com/code.htm
'--------------------------------------------------------------------------------
'                              callImportWorksheets_AppendTable
'--------------------------------------------------------------------------------
' 
Sub callImportWorksheets_AppendTable()
   'launch ImportWorksheets_AppendTable
   'customize sPathFile and sTableName, use defaults for optional parameters 
   Dim sPathFile As String _
      , sSheetNumberStart As Integer _
      , sTableName As String
   sTableName = "MyTablename"
   sPathFile = "c:\path\filename.xlsx"
   Call ImportWorksheets_AppendTable( sTableName, sPathFile )
End Sub

'--------------------------------------------------------------------------------
'                              ImportWorksheets_AppendTable
'--------------------------------------------------------------------------------
' 
Sub ImportWorksheets_AppendTable( _
   psTableName As String _
   , psPathFile As String _
   , Optional piSheetNumberStart As Integer = 1 _
   , Optional booUpdateLinks As Boolean = False _
   , Optional piSpreadSheetType As integer = 10 _
   )
'160722, 181201 strive4peace
'import worksheets starting with piSheetNumberStart
'append contents to table name specified
'NOTE: TransferSpreadsheet assumes that fieldnames are at the top of each column in Excel   

   'PARAMETERS
   '   psTableName is the Access table name to append to
   '   psPathFile is the Excel file to import
   '   piSheetNumberStart is the first sheet number in Excel to get (default=1)
   '   booUpdateLinks is True if linked data should be refreshed (default=False) 
   '   piSpreadSheetType: 10 is Microsoft Excel 2010/2013/2016 XML format 
   '       Enumeration https://docs.microsoft.com/en-us/office/vba/api/Access.AcSpreadSheetType

   On Error GoTo Proc_Err
   
   Dim i As Integer _
      , iNumSheets As Integer _
      , sSheetReference As String
      
   'early binding for development
'   Dim xlApp As Excel.Application _
'      , xlWb As Excel.Workbook _
'      , xlWs As Excel.Worksheet
  
   'late binding for deployment      
   Dim xlApp As Object _
      , xlWb As Object _
      , xlWs As Object
   
   Set xlApp = CreateObject("Excel.Application")
   Set xlWb = xlApp.Workbooks.Open(psPathFile, booUpdateLinks)
   
   iNumSheets = xlWb.Worksheets.Count
   Debug.Print "Transferring from " & psPathFile   
   
   For i = piSheetNumberStart To iNumSheets
      sSheetReference = xlWb.Worksheets(i).Name & "$"
      Debug.Print space(3) & sSheetReference
      
      DoCmd.TransferSpreadsheet acImport _
         , piSpreadSheetType _
         , psTableName _
         , psPathFile _
         , True _
         , sSheetReference
   Next i
   
   MsgBox "transferred " & iNumSheets - 1 & " worksheets" _
      & " from " & psPathFile _
      , , "done"
   
Proc_Exit:
   On Error Resume Next
   Set xlWs = Nothing
   xlWb.Close False
   Set xlWb = Nothing
   xlApp.Quit
   Set xlApp = Nothing
   Exit Sub
Proc_Err:
   MsgBox Err.Description _
     , , "ERROR " & Err.Number & "   ImportWorksheets_AppendTable"
   Resume Proc_Exit
   Resume
End Sub
'
' LICENSE
'   You may freely use and share this code 
'     provided this license notice and comment lines are not changed;
'     code may be modified provided you clearly note your changes.
'   You may not sell this code alone, or as part of a collection,
'     without my handwritten permission.
'   All ownership rights reserved. Use at your own risk.  
'   ~ crystal (strive4peace)  www.MsAccessGurus.com
'*************** Code End *******************************************************