I'm trying to import multiple Excelfiles with multiple sheets.

Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True

strFileName = "C:\SomeFile\File.xlsx"

Set objWorkbook = objExcel.Workbooks.Open(strFileName)
Set colWorksheets = objWorkbook.Worksheets

For Each objWorksheet in colWorksheets 
    Set objRange = objWorksheet.UsedRange 
    strWorksheetName = objWorksheet.Name & "!" & objRange.Address(False, False) 
    objAccess.DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
        "Vulnerability", strFileName, True, strWorksheetName
Next

I have a problem with the range. The variable strWorksheetName = "BE900!A1:L1634".

I get a runtime-error '3011'. The "!" is replaced by "$" so the sheet isn't found.

Any ideas?

ALL of my code

Public Function ImportFiles() Dim strFolder As String Dim db As DAO.Database Dim qdf As DAO.QueryDef Dim strFile As String Dim strTable As String Dim strExtension As String Dim lngFileType As Long Dim strSQL As String Dim strFullFileName As String Dim varPieces As Variant

With Application.FileDialog(3) ' msoFileDialogFolderPicker
.AllowMultiSelect = True
.Title = "Please select one or more files"
.Initialfilename = "*.xls*"

If .Show Then
    strFullFileName = .SelectedItems(1)
Else
    MsgBox "No folder specified!", vbCritical
    Exit Function
End If
End With

strFile = Dir(strFolder)

Set db = CurrentDb()

strFile = Dir(strFolder & "*.xls*")
Do While Len(strFile) > 0
strTable = DetermineTable(strFile)

strSQL = "UPDATE [" & strTable & "] SET FileName=[pFileName]" & vbCrLf & _
"WHERE FileName Is Null OR FileName='';"
Set qdf = db.CreateQueryDef(vbNullString, strSQL)

varPieces = Split(strFile, ".")
strExtension = varPieces(UBound(varPieces))
Select Case strExtension
    Case "xls"
        lngFileType = acSpreadsheetTypeExcel9
    Case "xlsx", "xlsm"
        lngFileType = acSpreadsheetTypeExcel12Xml
    Case "xlsb"
        lngFileType = acSpreadsheetTypeExcel12
End Select

Set objexcel = CreateObject("Excel.Application")
Set objworkbook = objexcel.Workbooks.Open(strFullFileName)
Set colworksheets = objworkbook.Worksheets

For Each objWorksheet In colworksheets
    Set objRange = objWorksheet.UsedRange
    **strWorksheetName = objWorksheet.Name & "!" & objRange.Address(False, False)**
    'strWorksheetName = objRange.Address(0, 0, external:=True)
        DoCmd.TransferSpreadsheet _
                TransferType:=acImport, _
                SpreadsheetType:=lngFileType, _
                tableName:=strTable, _
                FileName:=strFile, _
                HasFieldNames:=False, _
                **Range:=CStr(strWorksheetName)**
Next

colworksheets.Close
colworksheets = Nothing
objworkbook.Close
objworkbook = Nothing
objexcel.Close
objexcel = Nothing

Set db = CurrentDb()
Set tdf = db.TableDefs(strTable)

'Add the field to the table.
If FieldExistsInTable(strTable, "FileName") = True Then
    'Do nothing
Else
    tdf.Fields.Append tdf.CreateField("FileName", dbText, 255)
    'tdf.fields.append tdf.createField("SheetName", dbText, 255)
End If

'Supply the parameter value for the UPDATE and execute it ...
qdf.Parameters("pFileName").Value = strFile
qdf.Execute 'dbFailOnError

'Move to the next file
strFile = Dir
 Loop

Set fld = Nothing
Set tdf = Nothing
Set db = Nothing
'rstTable.Close
Set rstTable = Nothing

End Function

CodePudding user response：

Macro does not have an error, works well in my PC.

You can try a PC restart.

I this does not help, you may define strWorksheetName2, replace $ in strWorksheetName with !. Then give it to access object.

CodePudding user response：

Rebuilded the code from scratch in a new db, now it works. Thanks for the assistance.