Hi Mario,
Use the transferspreadsheet method of DoCmd. See a code that opens
multipliple workbooks with multiple worksheets and load them into one table
and adds 4 extra columns, then fill the 4 extra columns with the names of the
workbooks and worksheets.
Private Sub Command2_Click()
'Dim strSheet() As String
'xlsSheetLoop (strSheet())
Dim xlApp As Excel.Application
Dim xlWS As Excel.Worksheet
Dim xlWB As Excel.Workbook
Dim i As Integer
Dim strFileName As String
Dim strOpenFile As String
Dim strNameOnly As String
Dim intTableExistTest As Integer
Dim wkShName As String
Dim objFSO As Object
Dim objFile As Object
Dim strFolderPath As String
Dim strPath As String
Dim strPathBrowser As String
Dim bookName As String
Dim intCellValue As Integer
Dim fieldValue As Field
Dim rangeValue As Range
Dim strFileNameValue As String
Dim workBookName As Names
Dim strFullPath As String
Dim j As Integer
Dim strActiveBook As Object
Dim strDefaultPath As String
Dim strTableNames As String
Dim dtDataTable As DataTable
Dim tbl As ADOX.Table
Dim strSQL As String
Set xlApp = New Excel.Application
On Error Resume Next
''Folder browser function
strDefaultPath = BrowseFolder("Select Folder") & "\"
strPath = strDefaultPath
strFileName = Dir(strPath & "*.xls")
strFullPath = strPath & strFileName
Do While Len(strFileName) > 0
strFullPath = strPath & strFileName
strFileNameValue = strFileName
strNameOnly = Left(strFileName, Len(strFileName) - 4)
Set xlWB = xlApp.Workbooks.Open(strFullPath, , , , "dulan")
For j = 1 To xlApp.Worksheets.Count
Set xlWS = xlApp.ActiveWorkbook.Worksheets(j)
xlWS.Unprotect ("dulan")
wkShName = xlWS.Name
strBudgetCat = Left(wkShName, Len(wkShName) - 6)
strSubCat = Left(wkShName, Len(wkShName) - 5)
DoCmd.TransferSpreadsheet acImport, , "NonVolSen_Table", strFullPath, -1,
wkShName & "!A13:Q33"
DoCmd.RunSQL "ALTER TABLE NonVolSen_Table ADD COLUMN CostCentreCode CHAR,
GLCode CHAR, BudCat CHAR, SubCat CHAR", -1
strSQL = "UPDATE NonVolSen_Table SET CostCentreCode = '" & strNameOnly & "',
GLCode = '" & wkShName & "', BudCat = '" & strBudgetCat & "', SubCat = '" &
strSubCat & "' WHERE CostCentreCode IS NULL"
CurrentDb.Execute strSQL, dbFailOnError
Next j
strFileName = Dir()
Set xlWB = Nothing
Loop
End Sub
The BrowseFolder is a Function. Put it in a separate Module and called it.
See the codes of the BrowseFolder:
Option Explicit
'************** Code Start **************
'This code was originally written by Terry Kreft.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code courtesy of
'Terry Kreft
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long
Private Const BIF_RETURNONLYFSDIRS = &H1
Public Function BrowseFolder(szDialogTitle As String) As String
Dim X As Long, bi As BROWSEINFO, dwIList As Long
Dim szPath As String, wPos As Integer
With bi
.hOwner = hWndAccessApp
.lpszTitle = szDialogTitle
.ulFlags = BIF_RETURNONLYFSDIRS
End With
dwIList = SHBrowseForFolder(bi)
szPath = Space$(512)
X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
If X Then
wPos = InStr(szPath, Chr(0))
BrowseFolder = Left$(szPath, wPos - 1)
Else
BrowseFolder = vbNullString
End If
End Function
'*********** Code End *****************
Good luck
