jedwards2
asked on
Import Excel Spreadsheet Information into Access Table
I have been surfing the web looking for tips or functions to do this below.
I am trying to import data from spreadsheets using the Dir function. Also search subfolders if needed. I need to loop through all the sheetnames in the spreadsheet and import the data into one table. I am creating a table called spreadsheet names to join the id to the id in the data table. There may be a better way to this but I need some help. Can someone hopefully lead me in the right direction? I have a project I am doing that requires this functionality.
I am trying to import data from spreadsheets using the Dir function. Also search subfolders if needed. I need to loop through all the sheetnames in the spreadsheet and import the data into one table. I am creating a table called spreadsheet names to join the id to the id in the data table. There may be a better way to this but I need some help. Can someone hopefully lead me in the right direction? I have a project I am doing that requires this functionality.
ASKER
I was stepping through each line of code to see the values for the strings. The code breaks at the line below.
Set objWkBook = GetObject("" & strFilename & "")
There is no function specified for the code that was sent to me. Any help would be appreciated.
Set objWkBook = GetObject("" & strFilename & "")
There is no function specified for the code that was sent to me. Any help would be appreciated.
ASKER
OK. I got that to work myself.
How do I search through a directory and subfolders to have strFileName listed through a loop.
How do I search through a directory and subfolders to have strFileName listed through a loop.
you can add these codes
Dim fs As Object, j As Integer
Set fs = Application.FileSearch
With fs
.LookIn = "C:\FolderName"
.fileName = "*.xls"
.SearchSubFolders = True 'this will search the sub folders too
If .Execute > 0 Then
For j = 1 To .FoundFiles.Count
strFileName = .FoundFiles(j)
insert
the codes above
next j
ASKER
I am getting a compile error. The code is below.....
Option Compare Database
Function GetWorkbook()
Dim objWkBook As Excel.Workbook
Dim objSheet As Worksheet
Dim strWBname As String
Dim strWSname As String
Dim i As Integer
Dim intCount As Integer
Dim strFilename, tblName, TableName As String
Dim newFileName As String
Dim fs As Object, j As Integer
On Error GoTo GetWorkbook_Err
Set fs = Application.FileSearch
With fs
.LookIn = "\\C:\Test\"
.Filename = "*.xls"
.SearchSubFolders = True 'this will search the sub folders too
If .Execute > 0 Then
For j = 1 To .FoundFiles.Count
strFilename = .FoundFiles(j)
newFileName = Mid(Left$([strFilename], InStr(1, [strFilename], ".") - 1), 4)
tblName = newFileName
Set objWkBook = GetObject("" & strFilename & "")
strWBname = objWkBook.Name
'intCount = (objWkBook.Sheets.Count) - 1 ' use either of this two
intCount = (objWkBook.Sheets.Count) ' this one works on mine
For i = 1 To (intCount)
Set objSheet = objWkBook.Sheets(i)
strWSname = objSheet.Name
Debug.Print i; intCount; strWSname 'use this for testing on the immediate window
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
"" & tblName & strWSname & "", strFilename, True, "" & strWSname & "!"
Next i
Next j
objWkBook.Application.Quit
Set objWkBook = Nothing
Set objSheet = Nothing
GetWorkbook_Exit:
Exit Function
GetWorkbook_Err:
Debug.Print i; intCount; strWSname
MsgBox Err.Number & " " & Err.Description
Resume GetWorkbook_Exit
End Function
Option Compare Database
Function GetWorkbook()
Dim objWkBook As Excel.Workbook
Dim objSheet As Worksheet
Dim strWBname As String
Dim strWSname As String
Dim i As Integer
Dim intCount As Integer
Dim strFilename, tblName, TableName As String
Dim newFileName As String
Dim fs As Object, j As Integer
On Error GoTo GetWorkbook_Err
Set fs = Application.FileSearch
With fs
.LookIn = "\\C:\Test\"
.Filename = "*.xls"
.SearchSubFolders = True 'this will search the sub folders too
If .Execute > 0 Then
For j = 1 To .FoundFiles.Count
strFilename = .FoundFiles(j)
newFileName = Mid(Left$([strFilename], InStr(1, [strFilename], ".") - 1), 4)
tblName = newFileName
Set objWkBook = GetObject("" & strFilename & "")
strWBname = objWkBook.Name
'intCount = (objWkBook.Sheets.Count) - 1 ' use either of this two
intCount = (objWkBook.Sheets.Count) ' this one works on mine
For i = 1 To (intCount)
Set objSheet = objWkBook.Sheets(i)
strWSname = objSheet.Name
Debug.Print i; intCount; strWSname 'use this for testing on the immediate window
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
"" & tblName & strWSname & "", strFilename, True, "" & strWSname & "!"
Next i
Next j
objWkBook.Application.Quit
Set objWkBook = Nothing
Set objSheet = Nothing
GetWorkbook_Exit:
Exit Function
GetWorkbook_Err:
Debug.Print i; intCount; strWSname
MsgBox Err.Number & " " & Err.Description
Resume GetWorkbook_Exit
End Function
ASKER
I changed the code to get it to work. I am testing it now.
sorry i wasn't able to get back to you soon, got busy..
try this
Private Sub Command1_Click()
Dim objWkBook As Excel.Workbook
Dim objSheet As Worksheet
Dim strWBname As String
Dim strWSname As String
Dim i As Integer, j As Integer
Dim intCount As Integer
Dim strFilename, tblName As String, sFileName As String
Dim fs As Object, j As Integer
Set fs = Application.FileSearch
With fs
.LookIn = "C:\ExcelFiles"
.fileName = "*.xls"
.SearchSubFolders = True 'this will search the sub folders too
If .Execute > 0 Then
For j = 1 To .FoundFiles.Count
strFilename = .FoundFiles(j)
sFileName = Dir(.FoundFiles(j))
tblName = Mid(Left$([sFileName], InStr(1, [sFileName], ".") - 1), 1)
Set objWkBook = GetObject("" & strFilename & "")
strWBname = objWkBook.Name
'intCount = (objWkBook.Sheets.Count) - 1 ' use either of this two
intCount = (objWkBook.Sheets.Count) ' this one works on mine
For i = 1 To (intCount)
Set objSheet = objWkBook.Sheets(i)
strWSname = objSheet.Name
' Debug.Print i; intCount; strWSname 'use this for testing on the immediate window
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
"" & tblName & strWSname & "", strFilename, True, "" & strWSname & "!"
Next i
objWkBook.Application.Quit
Set objWkBook = Nothing
Set objSheet = Nothing
Next j
End If
End With
GetWorkbook_Exit:
Exit Sub
GetWorkbook_Err:
Debug.Print i; intCount; strWSname
MsgBox Err.Number & " " & Err.Description
Resume GetWorkbook_Exit
End Sub
try this
Private Sub Command1_Click()
Dim objWkBook As Excel.Workbook
Dim objSheet As Worksheet
Dim strWBname As String
Dim strWSname As String
Dim i As Integer, j As Integer
Dim intCount As Integer
Dim strFilename, tblName As String, sFileName As String
Dim fs As Object, j As Integer
Set fs = Application.FileSearch
With fs
.LookIn = "C:\ExcelFiles"
.fileName = "*.xls"
.SearchSubFolders = True 'this will search the sub folders too
If .Execute > 0 Then
For j = 1 To .FoundFiles.Count
strFilename = .FoundFiles(j)
sFileName = Dir(.FoundFiles(j))
tblName = Mid(Left$([sFileName], InStr(1, [sFileName], ".") - 1), 1)
Set objWkBook = GetObject("" & strFilename & "")
strWBname = objWkBook.Name
'intCount = (objWkBook.Sheets.Count) - 1 ' use either of this two
intCount = (objWkBook.Sheets.Count) ' this one works on mine
For i = 1 To (intCount)
Set objSheet = objWkBook.Sheets(i)
strWSname = objSheet.Name
' Debug.Print i; intCount; strWSname 'use this for testing on the immediate window
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
"" & tblName & strWSname & "", strFilename, True, "" & strWSname & "!"
Next i
objWkBook.Application.Quit
Set objWkBook = Nothing
Set objSheet = Nothing
Next j
End If
End With
GetWorkbook_Exit:
Exit Sub
GetWorkbook_Err:
Debug.Print i; intCount; strWSname
MsgBox Err.Number & " " & Err.Description
Resume GetWorkbook_Exit
End Sub
ASKER
I am getting a mismatch error at this line.
This piece of code "Set objSheet = objWkBook.Sheets(i)
strWSname = objSheet.Name AND strWSname <> "Checklist"" is not allowing me to filter out this worksheet named Checklist.
The complete function is below. I made a couple of changes so it would not ask to save and would close the instance of excel. I am almost there appreciate all your help.
Option Compare Database
Public Function LoadData()
Dim xl As Excel.Application
Dim objWkBook As Excel.Workbook
Dim objSheet As Worksheet
Dim strWBname As String
Dim strWSname As String
Dim i As Integer, j As Integer
Dim intCount As Integer
Dim strFilename, tblName As String, sFileName As String
Dim fs As Object
Set fs = Application.FileSearch
With fs
.LookIn = "\\C:Test"
.fileName = "*.xls"
.SearchSubFolders = True 'this will search the sub folders
If .Execute > 0 Then
For j = 1 To .FoundFiles.Count
strFilename = .FoundFiles(j)
sFileName = Dir(.FoundFiles(j))
tblName = Mid(Left$([sFileName], InStr(1, [sFileName], ".") - 1), 1)
Set xl = New Excel.Application
Set objWkBook = GetObject("" & strFilename & "")
strWBname = objWkBook.Name
'intCount = (objWkBook.Sheets.Count) - 1
intCount = (objWkBook.Sheets.Count)
For i = 1 To (intCount)
Set objSheet = objWkBook.Sheets(i)
strWSname = objSheet.Name AND strWSname <> "Checklist"
Debug.Print i; intCount; strWSname 'use this for testing on the immediate window
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
"" & tblName & strWSname & "", strFilename, True, "" & strWSname & "!"
Next i
objWkBook.Close False
xl.Application.Quit
Set objWkBook = Nothing
Set objSheet = Nothing
Set xl = Nothing
Next j
End If
End With
GetWorkbook_Exit:
Exit Function
GetWorkbook_Err:
Debug.Print i; intCount; strWSname
MsgBox Err.Number & " " & Err.Description
Resume GetWorkbook_Exit
End Function
This piece of code "Set objSheet = objWkBook.Sheets(i)
strWSname = objSheet.Name AND strWSname <> "Checklist"" is not allowing me to filter out this worksheet named Checklist.
The complete function is below. I made a couple of changes so it would not ask to save and would close the instance of excel. I am almost there appreciate all your help.
Option Compare Database
Public Function LoadData()
Dim xl As Excel.Application
Dim objWkBook As Excel.Workbook
Dim objSheet As Worksheet
Dim strWBname As String
Dim strWSname As String
Dim i As Integer, j As Integer
Dim intCount As Integer
Dim strFilename, tblName As String, sFileName As String
Dim fs As Object
Set fs = Application.FileSearch
With fs
.LookIn = "\\C:Test"
.fileName = "*.xls"
.SearchSubFolders = True 'this will search the sub folders
If .Execute > 0 Then
For j = 1 To .FoundFiles.Count
strFilename = .FoundFiles(j)
sFileName = Dir(.FoundFiles(j))
tblName = Mid(Left$([sFileName], InStr(1, [sFileName], ".") - 1), 1)
Set xl = New Excel.Application
Set objWkBook = GetObject("" & strFilename & "")
strWBname = objWkBook.Name
'intCount = (objWkBook.Sheets.Count) - 1
intCount = (objWkBook.Sheets.Count)
For i = 1 To (intCount)
Set objSheet = objWkBook.Sheets(i)
strWSname = objSheet.Name AND strWSname <> "Checklist"
Debug.Print i; intCount; strWSname 'use this for testing on the immediate window
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
"" & tblName & strWSname & "", strFilename, True, "" & strWSname & "!"
Next i
objWkBook.Close False
xl.Application.Quit
Set objWkBook = Nothing
Set objSheet = Nothing
Set xl = Nothing
Next j
End If
End With
GetWorkbook_Exit:
Exit Function
GetWorkbook_Err:
Debug.Print i; intCount; strWSname
MsgBox Err.Number & " " & Err.Description
Resume GetWorkbook_Exit
End Function
ASKER
Or if I could ignore runtime error 3011 while looping through the worksheets.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
This works great. I appreciate all your help.
Function GetWorkbook()
Dim objWkBook As Excel.Workbook
Dim objSheet As Worksheet
Dim strWBname As String
Dim strWSname As String
Dim i As Integer
Dim intCount As Integer
Dim strFilename, tblName, TableName As String
Dim newFileName As String
On Error GoTo GetWorkbook_Err
strFilename = "c:\Test.xls"
newFileName = Mid(Left$([strFilename], InStr(1, [strFilename], ".") - 1), 4)
tblName = newFileName
Set objWkBook = GetObject("" & strFilename & "")
strWBname = objWkBook.Name
'intCount = (objWkBook.Sheets.Count) - 1 ' use either of this two
intCount = (objWkBook.Sheets.Count) ' this one works on mine
For i = 1 To (intCount)
Set objSheet = objWkBook.Sheets(i)
strWSname = objSheet.Name
'Debug.Print i; intCount; strWSname 'use this for testing on the immediate window
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
"" & tblName & strWSname & "", strFilename, True, "" & strWSname & "!"
Next i
objWkBook.Application.Quit
Set objWkBook = Nothing
Set objSheet = Nothing
GetWorkbook_Exit:
Exit Function
GetWorkbook_Err:
Debug.Print i; intCount; strWSname
MsgBox Err.Number & " " & Err.Description
Resume GetWorkbook_Exit
End Function