Importing several Excel files into Access using VBA (1 Viewer)

johnctholen · Jun 16, 2014

Hi all,

I am very new to using VBA so could really use some basic help! I have a set of Excel files with several worksheets in each. These worksheet names are common across the files and all of the files are located in one folder.

I want to import all of these files into Access as separate tables (well ultimately it would be great to combine the worksheets from various files into tables by worksheet but that can wait).

I have the following code which I found in a tutorial only when I click the button to run the code nothing is happening! Please help.

Code:

Option Compare Database
Private Sub Command0_Click()
Dim blnHasFieldNames As Boolean, blnEXCEL As Boolean, blnReadOnly As Boolean
Dim intWorkbookCounter As Integer
Dim lngCount As Long
Dim objExcel As Object, objWorkbook As Object
Dim colWorksheets As Collection
Dim strPath As String, strFile As String
Dim strPassword As String
' Establish an EXCEL application object
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
      Set objExcel = CreateObject("Excel.Application")
      blnEXCEL = True
End If
Err.Clear
Err.Clear
On Error GoTo 0
' Change this next line to True if the first row in EXCEL worksheet
' has field names
blnHasFieldNames = True
' Replace C:\MyFolder\ with the actual path to the folder that holds the EXCEL files
strPath = "C:\Users\tholen-1\Desktop\Extract_Thru_May_31"
' Replace passwordtext with the real password;
' if there is no password, replace it with vbNullString constant
' (e.g., strPassword = vbNullString)
strPassword = vbNullString
blnReadOnly = True ' open EXCEL file in read-only mode
strFile = Dir(strPath & "*.xls")
intWorkbookCounter = 0
Do While strFile <> ""
      intWorkbookCounter = intWorkbookCounter + 1
      Set colWorksheets = New Collection
      Set objWorkbook = objExcel.Workbooks.Open(strPath & strFile, , _
            blnReadOnly, , strPassword)
      For lngCount = 1 To objWorkbook.Worksheets.Count
            colWorksheets.Add objWorkbook.Worksheets(lngCount).Name
      Next lngCount
      ' Close the EXCEL file without saving the file, and clean up the EXCEL objects
      objWorkbook.Close False
      Set objWorkbook = Nothing
      ' Import the data from each worksheet into a separate table
      For lngCount = colWorksheets.Count To 1 Step -1
            DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
                  "tbl" & colWorksheets(lngCount) & intWorkbookCounter, _
                  strPath & strFile, blnHasFieldNames, _
                  colWorksheets(lngCount) & "$"
      Next lngCount
      ' Delete the collection
      Set colWorksheets = Nothing
      ' Uncomment out the next code step if you want to delete the
      ' EXCEL file after it's been imported
      ' Kill strPath & strFile
      strFile = Dir()
Loop
If blnEXCEL = True Then objExcel.Quit
Set objExcel = Nothing
 
 
End Sub

Rx_ · Jun 16, 2014

Time you learn these things.
1. On Error Resume Next - change to On Error GoTo errTrap
2. Just above End Sub - add this code

Code:

   Exit Sub
     errTrap:
    debug.print "The error was " & err.number & "  " & err.description
    ' in a code window press Control+G
   err.clear
   on error resume next
 objexcel.visible = true

3 in your code window, in the left gray bar in from of your code, click to put a red dot (breakpoint) at the line that includes SET statement.
4 Run this code, it will stop at the break point. Use F5 key to step through the code.
5. Report back to us what line is causing the error, and the neature of the error shown in your Immediate Window.

You will be up and going in no time by following this now, and for all future questions.

johnctholen · Jun 16, 2014

Wow thank you for the tip Rx.

When I perform this action it highlights the line in the code you gave me.

objexcel.visible = true
with "The error was 429 ActiveX component can't create object"

Rx_ · Jun 16, 2014

In the code window with the cursor in your subroutine:
Code menu Debug - Compile ...
What do you get?
My gues is that in Tool Reference, the Excel (your version) doesn't have a checkbox in it.

While you are at it, change the Dim
from Dim objExcel As Object to Dim objExcel As Excel.Application

From now on, every time any code you write is changed, go to Debug - Compile.

Rx_ · Jun 16, 2014

See attachment:
This red line is a break point, click where the red dot is at to toggle on/off
When you run, the code will stop here. Then use the F8 (sorry about F5) key to single step through the code.
If the cursor suddenly jumps to the errTrap, that was the line of code that failed.

johnctholen · Jun 16, 2014

When I execute debug -> compile db, nothing seems to happen.

In references --> tools I have Microsoft Excel 14.0 OBject Library checked and don't see any other excel items.

When I try to step through the code it skips straight from the break at
Set objExcel = GetObject(, "Excel.Application")
down to the
Debug.Print "The error... " line and then still returns the same error at the
objExcel.Visible = True line.

I am sorry if there is something I am missing but I can't thank you enough for trying to help me out, I am a bit lost here.

Rx_ · Jun 17, 2014

How to use the immediate window : http://www.baldyweb.com/ImmediateWindow.htm
Good, it jumps directly from your SET to debug and then has a error about object.
That means the error happens when executing that line of code.
instead of
Set objExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set objExcel = CreateObject("Excel.Application")

lets try this:
If objxl Is Nothing Then ' check that last instance isn't there during testing
Set objxl = New Excel.Application
objxl.EnableEvents = False
Else
Excel.Application.Quit
DoEvents
Set objxl = New Excel.Application ' lets use this method instead of Get Object
objxl.EnableEvents = False
End If
On Error GoTo errTrap
objxl.Visible = False ' *** turn this to True when Testing, stepping through!!
objxl.Workbooks.Add
'objXL.Worksheets.Add ' if your default worksheet isn't 3
intWorksheetNum = 1
intRowPos = 1
'objXL.Worksheets(intWorksheetNum).Cells(intRowPos, 1) = "Created: " & Now() ' created header as last item below
objxl.Worksheets(intWorksheetNum).Name = "StipException"

johnctholen · Jun 17, 2014

Rx, thank you for continuing to work with me here!

Error in this line ==> objxl.Visible = True

"The error was 91 Object variable or With block variable not set"

Rx_ · Jun 17, 2014

objExcel is your name, I used Objxl for mine.
You will need to modify my variables to meet the names you defined.
So, you are using the debugger and step through?
This will enable things to progress much faster now.

johnctholen · Jun 17, 2014

Oops. Ok so with the variable names fixed I am able to step through my code with no error messages.

I am confused on the purpose of this new code though was this just to test some things?

Rx_ · Jun 17, 2014

Please use code tags and send back the code you have together now.
Lets see what is working now that the error is gone.
I sent working code to avoid troubleshooting your version. Basically, I am lazy?

johnctholen · Jun 17, 2014

Lazy is far from a good word to describe you after how much effort you are putting in to helping me out!

Code:

Private Sub Command0_Click()
Dim blnHasFieldNames As Boolean, blnEXCEL As Boolean, blnReadOnly As Boolean
Dim intWorkbookCounter As Integer
Dim lngCount As Long
Dim objExcel As Excel.Application, objWorkbook As Object
Dim colWorksheets As Collection
Dim strPath As String, strFile As String
Dim strPassword As String
' Establish an EXCEL application object
On Error Resume Next
Set objExcel = New Excel.Application
If Err.Number <> 0 Then
      Set objExcel = CreateObject("Excel.Application")
      blnEXCEL = True
End If
Err.Clear
On Error GoTo errTrap
' Change this next line to True if the first row in EXCEL worksheet
' has field names
blnHasFieldNames = True
' Replace C:\MyFolder\ with the actual path to the folder that holds the EXCEL files
strPath = "C:\Users\tholen-1\Desktop\Extract_Thru_May_31"
' Replace passwordtext with the real password;
' if there is no password, replace it with vbNullString constant
' (e.g., strPassword = vbNullString)
strPassword = vbNullString
blnReadOnly = True ' open EXCEL file in read-only mode
strFile = Dir(strPath & "*.xls")
intWorkbookCounter = 0
Do While strFile <> ""
      intWorkbookCounter = intWorkbookCounter + 1
      Set colWorksheets = New Collection
      Set objWorkbook = objExcel.Workbooks.Open(strPath & strFile, , _
            blnReadOnly, , strPassword)
      For lngCount = 1 To objWorkbook.Worksheets.Count
            colWorksheets.Add objWorkbook.Worksheets(lngCount).Name
      Next lngCount
      ' Close the EXCEL file without saving the file, and clean up the EXCEL objects
      objWorkbook.Close False
      Set objWorkbook = Nothing
      ' Import the data from each worksheet into a separate table
      For lngCount = colWorksheets.Count To 1 Step -1
            DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
                  "tbl" & colWorksheets(lngCount) & intWorkbookCounter, _
                  strPath & strFile, blnHasFieldNames, _
                  colWorksheets(lngCount) & "$"
      Next lngCount
      ' Delete the collection
      Set colWorksheets = Nothing
      ' Uncomment out the next code step if you want to delete the
      ' EXCEL file after it's been imported
      ' Kill strPath & strFile
      strFile = Dir()
Loop
If blnEXCEL = True Then objExcel.Quit
Set objExcel = Nothing
 
 
Exit Sub
errTrap:
    Debug.Print "The error was " & Err.Number & "  " & Err.Description
    ' in a code window press Control+G
   Err.Clear
   On Error Resume Next
 objExcel.Visible = True
 
 
End Sub

Rx_ · Jun 18, 2014

Will be busy the rest of today.
Create a simple query based on one of your tables and substitute your query for my SQL string.
Test this down to the point of line 410.
This uses a Recordset to move the data over and provides a lot of control at the Excel level.
See if it is something that might be of interest.

Code:

Option Compare Database
Option Explicit
Public Sub PopulateExcel() ' just put this subroutine name in your click event
      ' to run from Immediate window, type PopulateExcel and enter
      ' be sure to put a breakpoint in the set objExcel line to step through
      Dim blnHasFieldNames As Boolean, blnEXCEL As Boolean, blnReadOnly As Boolean
      Dim intWorkbookCounter As Integer
      Dim lngCount As Long
      Dim objExcel As Excel.Application, objWorkbook As Object
      Dim colWorksheets As Collection
      Dim strPath As String, strFile As String
      Dim strPassword As String
      Dim MyXLWorkbookLocation As String
      ' Establish an EXCEL application object
10    On Error Resume Next
20    Set objExcel = New Excel.Application
30    If Err.Number = 0 Then
40    Set objExcel = CreateObject("Excel.Application")
50    blnEXCEL = True
60        objExcel.Visible = True   ' this will make excel visible - change to false for production
70        objExcel.DisplayAlerts = False
80        objExcel.Workbooks.Add
90        objExcel.Worksheets.Add
100       objExcel.Sheets(1).Select
110       objExcel.Sheets(1).Name = "MyData" ' change as needd
120       objExcel.Sheets(1).Range("A1").Select ' go set focus on Excel workbook and see that A1 is selected
          ' then put focus back on this module
130   End If
140   Err.Clear
150   On Error GoTo errTrap
      ' Change this next line to True if the first row in EXCEL worksheet
      ' has field names
160   blnHasFieldNames = True
      ' Replace C:\MyFolder\ with the actual path to the folder that holds the EXCEL files
170   strPath = "C:\APP"
      ' Replace passwordtext with the real password;
      ' if there is no password, replace it with vbNullString constant
      ' (e.g., strPassword = vbNullString)
180   strPassword = vbNullString
190   blnReadOnly = True ' open EXCEL file in read-only mode
      'strFile = Dir(strPath & "*.xls")
200   intWorkbookCounter = 0
210       ActiveWorkbook.SaveAs FileName:=strPath & "\MyWorkbook" & intWorkbookCounter & ".xlsx", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
      ' if testing stops, go to the directory and delete the workbook just created then run code again - otherwise there is already a workbook with that name.
220       MyXLWorkbookLocation = strPath & "\MyWorkbook" & intWorkbookCounter & ".xlsx"
230       Debug.Print "The Workbook should be created now at " & MyXLWorkbookLocation
      ' Are you trying to read a query then push it over to the new workbook here?
      Dim mystrSQL As String
      Dim rsdata As Recordset
      Dim intRowPos As Integer
      Dim intWorksheetNum As Integer
      Dim intMaxRecordCount As Integer
      Dim intMaxheaderColCount As Integer
      Dim intHeaderColCount As Integer
240     mystrSQL = "SELECT Wells_Sundry_Type.* FROM Wells_Sundry_Type;"  ' put your actial sql statement here
250       Debug.Print " sql string =  " & mystrSQL
260   Set rsdata = CurrentDb.OpenRecordset(mystrSQL, dbOpenDynaset, dbSeeChanges) '
      'Set rsData = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
270     intWorksheetNum = 1 ' this can be a variable in a loop for the next one
280   intRowPos = 6                                                                                 ' Sets starting Row for data in Excel - reference fields to this
290   DoEvents
300   objExcel.DisplayAlerts = False                                                       ' Turn off Display Alerts
310   objExcel.Worksheets(intWorksheetNum).Cells(intRowPos, 1).CopyFromRecordset rsdata
320   DoEvents
330   intMaxRecordCount = rsdata.RecordCount - 1                                                      ' - use for max rows returned in formatting later
           'Debug.Print "max record count is " & intMaxRecordCount
                                            ' ------- Create Header in new Excel based on Query
340       intMaxheaderColCount = rsdata.Fields.Count - 1
350       For intHeaderColCount = 0 To intMaxheaderColCount
360     If Left(rsdata.Fields(intMaxheaderColCount).Name, 3) <> "xxx" Then  ' Future use - adding xxx in cross tab queries for fields to exclude
370   objExcel.Worksheets(intWorksheetNum).Cells(intRowPos - 1, intHeaderColCount + 1) = rsdata.Fields(intHeaderColCount).Name    ' Relative to intRowPos
380     End If
390       Next intHeaderColCount
          'Debug.Print "Columns created count is " & intHeaderColCount
400       objExcel.Rows((intRowPos - 1) & ":" & (intRowPos - 1)).Select                                    ' Selection for Bold header column (can make 2 if needed)
      ' check at this point your query data should have started at intRow position 6
      ' with the header at row 5
      ' see if this works, hten look at a loop to create a new worksheet, read the next query and repeat.
      ' The strFile is empty so it doesn't really run from here
410   Do While strFile <> ""
420   intWorkbookCounter = intWorkbookCounter + 1
430   Set colWorksheets = New Collection
440   Set objWorkbook = objExcel.Workbooks.Open(MyXLWorkbookLocation, , _
            blnReadOnly, , strPassword)
450   For lngCount = 1 To objWorkbook.Worksheets.Count
460         colWorksheets.Add objWorkbook.Worksheets(lngCount).Name
470   Next lngCount
      ' Close the EXCEL file without saving the file, and clean up the EXCEL objects
      ' Import the data from each worksheet into a separate table
480   For lngCount = colWorksheets.Count To 1 Step -1
490         DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
                  "tbl" & colWorksheets(lngCount) & intWorkbookCounter, _
                  MyXLWorkbookLocation, blnHasFieldNames, _
                  colWorksheets(lngCount) & "$"
500   Next lngCount
      ' Delete the collection
510   Set colWorksheets = Nothing
      ' Uncomment out the next code step if you want to delete the
      ' EXCEL file after it's been imported
      ' Kill strPath & strFile
520   strFile = Dir()
530   Loop
      'objWorkbook.Close False
      'Set objWorkbook = Nothing
540   If blnEXCEL = True Then objExcel.Quit
550   Set objExcel = Nothing
       
       
560   Exit Sub
errTrap:
570       Debug.Print "The error was " & Err.Number & "  " & Err.Description
          ' in a code window press Control+G
580      Err.Clear
590      On Error Resume Next
600    objExcel.Visible = True
       
       
End Sub

johnctholen · Jun 23, 2014

Hi Rx,

I ended up spending too much time trying to pursue this access solution and instead had to work around by building 2 macros in Excel which
1. Pull all of the 6 files together into one with separate worksheets (120 worksheets), and then
2. combine similar worksheets to create one master file with 20 worksheets which each contain all of the data from the respective worksheet in each of the original 6 files

I was then able to pull this workbook into Access as 20 separate tables, accomplishing my original goal.

I am very thankful for all the effort you put in and am sorry that I had to abandon this approach but I just was not finding a working solution and had to get this put together.

Importing several Excel files into Access using VBA (1 Viewer)

johnctholen

Registered User.

Rx_

Nothing In Moderation

johnctholen

Registered User.

Rx_

Nothing In Moderation

Rx_

Nothing In Moderation

Attachments

johnctholen

Registered User.

Rx_

Nothing In Moderation

johnctholen

Registered User.

Rx_

Nothing In Moderation

johnctholen

Registered User.

Rx_

Nothing In Moderation

johnctholen

Registered User.

Rx_

Nothing In Moderation

johnctholen

Registered User.

Similar threads

Users who are viewing this thread