Tom,
Just a quick and dirty fix...
Replace the code of the form frmImportRoutine with the code below:
Code:
Option Compare Database
Private Sub Form_Open(Cancel As Integer)
'Routine for Importing Data
Me.Listbox_ImportData.RowSource = "Import Source Data"
End Sub
Private Sub Listbox_ImportData_AfterUpdate()
'Routine for Importing Data
If Me.Listbox_ImportData = "Import Source Data" Then
'Declare variables for import routine
Dim blnHasFieldNames As Boolean
Dim blnEXCEL As Boolean
Dim blnReadOnly As Boolean
Dim intWorkbookCounter As Integer
Dim lngCount As Long
Dim objExcel As Object
Dim objWorkbook As Object
Dim colWorksheets As Collection
Dim strPath As String
Dim strFile As String
'Execute DROP TABLE command for all tables (source files) with a "tbl_" prefix
Dim tdf As TableDef
Dim strSQL As String
Dim db As DAO.Database
Set db = CurrentDb
For Each tdf In db.TableDefs
If Left(tdf.Name, 4) = "tbl_" Then
strSQL = "DELETE * FROM " & tdf.Name
Debug.Print strSQL
db.Execute strSQL
End If
Next
'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
On Error GoTo 0
'Change the next line to FALSE in the event the first row (in EXCEL file) does NOT have field names
blnHasFieldNames = True
'Set the file path
'strPath = "C:\Users\...\...\Import Routine\SourceData\2 Files\"
strPath = GetPath()
If Len(strPath) Then
If Right(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
'Open EXCEL files in read-only mode
blnReadOnly = True
strFile = Dir(strPath & "*.xlsx")
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 files without saving the file, and clean up the EXCEL objects
objWorkbook.Close False
Set objWorkbook = Nothing
'Import the data from each worksheet into separate tables
For lngCount = colWorksheets.Count To 1 Step -1
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
"tbl_" & colWorksheets(lngCount), _
strPath & strFile, blnHasFieldNames, _
colWorksheets(lngCount) & "$"
Next lngCount
'Delete the collection
Set colWorksheets = Nothing
strFile = Dir()
Loop
MsgBox intWorkbookCounter & " source files were successfully imported.", vbInformation, "Import Status"
End If
If blnEXCEL = True Then objExcel.Quit
Set objExcel = Nothing
End If
End Sub
Private Function GetPath() As String
'Browse for a folder...
Dim FD As FileDialog
Set FD = Application.FileDialog(msoFileDialogFolderPicker)
With FD
.AllowMultiSelect = False
.Title = "Select a folder"
.InitialFileName = CurrentProject.Path & "\"
If .Show Then
GetPath = .SelectedItems(1)
End If
End With
Set FD = Nothing
End Function
(My changes in blue)
I hope it works.
Question: Is there any case to import files with multiple worksheets?
Ciao!