使用多个工作表导入多个 excel 文件 - 范围问题

Question

我正在尝试使用多个工作表导入多个 Excel 文件。

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

我的范围有问题。变量 strWorksheetName = "BE900!A1:L1634"。

我收到运行时错误“3011”。这 ”！”被“$”替换，因此找不到工作表。

有什么想法吗？

我的所有代码

公共函数 ImportFiles() 将 strFolder 调暗为字符串 暗淡 db 作为 DAO.Database 将 qdf 调暗为 DAO.QueryDef 暗淡 strFile 作为字符串 将 strTable 调暗为字符串 暗淡 strExtension 作为字符串 将 lngFileType 变暗 将 strSQL 暗淡为字符串 将 strFullFileName 调暗为字符串 变暗 varPieces 作为变体

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

Answer 1

宏没有错误，在我的电脑上运行良好。

您可以尝试重启电脑。

我这没有帮助，您可以定义strWorksheetName2，将strWorksheetName 中的$ 替换为!。然后给它访问对象。

Answer 2

在一个新的数据库中从头开始重建代码，现在它可以工作了。 感谢您的帮助。