Link to home
Start Free TrialLog in
Avatar of jedwards2
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.
Avatar of Rey Obrero (Capricorn1)
Rey Obrero (Capricorn1)
Flag of United States of America image

try t his


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
Avatar of jedwards2
jedwards2

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.
OK.  I got that to work myself.

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

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

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
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
Or if I could ignore runtime error 3011 while looping through the worksheets.
ASKER CERTIFIED SOLUTION
Avatar of Rey Obrero (Capricorn1)
Rey Obrero (Capricorn1)
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
This works great.  I appreciate all your help.