时间戳

首页 > 解决方案 > 使用多张工作表导入多个 excelfiles - 范围问题

excel - 使用多张工作表导入多个 excelfiles - 范围问题

问题描述

我正在尝试使用多个工作表导入多个 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() 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

标签： excelvbagoogle-sheets

解决方案

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

推荐阅读