多个XLSX文件返回运行时错误9的VBA cellextract 9

Question

在工作中，我收到了大量的PDF表格。进入形式发生在PDF内的表中。必须将PDF中的特定条目输入Excel表（从现在开始称为跟踪器）。添加每个条目非常乏味。此方法也容易出错。

然后，我确定可以将每个PDF变成.xlsx文件，并保留表格格式。有了可以参考的单元格，我制作了一个vlookup公式，以提取跟踪器所需的确切信息。我只需要复制/粘贴表格范围从新创建的转换为.xlsx中的vlookup extractor .xlsx，所需的信息将填充我以粘贴到跟踪器中。

但是，使用此方法，我仍然需要将多个PDF转换为.xlsx，一个一个一个一个打开它们，将表粘贴到我的extractor .xlsx中，然后将新提取的数据复制并粘贴到跟踪器中。因此，仍然不太有效。我确定我需要一个宏。

我发现的宏应在指定文件夹中循环遍历.xlsx文件，打开它们并搜索指示的单元格。正如您在下面的宏中看到的那样，单元格不在任何一个范围内。我必须从特定单元格中提取值。

接下来，它应该从指示的单元格中提取值，并按照片段中的指示填充宏。

但是，无论我做什么，我都会不断获得'运行时错误9下标'。调试指向以下代码行，这是错误9：Set OpenWorksheet = OpenWorkbook.Worksheets(SheetName)

的原因

我尝试用Table1在有问题的线中替换SheetName，只是获得相同的错误。尝试了Sheet1，但然后获得运行时错误13。

我已经搜索网已经几个小时了，但是我找不到类似于我的案例。任何帮助将不胜感激。

宏如下：

Sub ExtractCells()
    ' local wb vars
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim MySheet As String
    Dim r1 As Range
    Dim r2 As Range
    Dim r3 As Range
    Dim r4 As Range
    Dim r5 As Range
    Dim r6 As Range
    Dim r7 As Range
    Dim r8 As Range
    Dim r9 As Range
    Dim r10 As Range
    Dim r11 As Range
    Dim r12 As Range
    Dim i As Integer
    ' opened wb vars
    Dim OpenWorkbook As Workbook
    Dim OpenWorksheet As Worksheet
    Dim SheetName As String
    ' looping params
    Dim Directory As String
    Dim FileSpec As String
    Dim MyFile As String
    ' define looping params
    Directory = "C:MultiPD TestForms" 'CHANGE THIS
    FileSpec = ".xlsx" 'CHANGE THIS IF NECESSARY
    MyFile = Dir(Directory & "*" & FileSpec)
    SheetName = "Table1" 'CHANGE THIS
    ' set local vars
    Set wb = ThisWorkbook
    MySheet = "Sheet1" 'CHANGE THIS
    Set ws = wb.Worksheets(MySheet)

    ' This is where data will begin to write
    Set r1 = ws.Range("A1")
    Set r2 = ws.Range("B1")
    Set r3 = ws.Range("C1")
    Set r4 = ws.Range("D1")
    Set r5 = ws.Range("E1")
    Set r6 = ws.Range("F1")
    Set r7 = ws.Range("G1")
    Set r8 = ws.Range("H1")
    Set r9 = ws.Range("I1")
    Set r10 = ws.Range("J1")
    Set r11 = ws.Range("K1")
    Set r12 = ws.Range("L1")
    i = 0
    ' If there is one thing you take away from this, it should be the construct below i.e. how to loop through files
    Do While MyFile <> ""
        Set OpenWorkbook = Application.Workbooks.Open(Filename:="C:MultiPD TestForms*.xlsx", ReadOnly:=True)
        Set OpenWorksheet = OpenWorkbook.Worksheets(SheetName)
        ' write data down col
        With OpenWorksheet
            r1.Offset(i, 0).Value = .Range("C4").Value
            r2.Offset(i, 0).Value = .Range("C6").Value
            r3.Offset(i, 0).Value = .Range("C8").Value
            r4.Offset(i, 0).Value = .Range("C10").Value
            r5.Offset(i, 0).Value = .Range("C12").Value
            r6.Offset(i, 0).Value = .Range("C15").Value
            r7.Offset(i, 0).Value = .Range("C16").Value
            r8.Offset(i, 0).Value = .Range("C22").Value
            r9.Offset(i, 0).Value = .Range("C35").Value
            r10.Offset(i, 0).Value = .Range("C36").Value
            r11.Offset(i, 0).Value = .Range("C37").Value
            r12.Offset(i, 0).Value = .Range("C38").Value
        End With
        i = i + 1
        MyFile = Dir
    Loop
End Sub

Answer 1

，如注释中所述：

• 第一行应该抛出运行时错误1004：file" ..."是：
  Application.Workbooks.Open(Filename:="C:MultiPD TestForms*.xlsx", ReadOnly:=True)
• 下一个问题是" table1"不是有效的表名称（似乎是ListObject名称）
• 一旦来自.xlsx文件的所有床单被重命名为Sheet1，您的代码工作

---

版本Bellow使用数组减少repetiton：

---

Option Explicit
Public Sub ExtractCellsFromMultiFiles()
    Const SRC_COL = 3
    Dim thisWS As Worksheet, wsName As String, srcRows As Variant
    Dim foldr As String, srcFile As String, ext As String
    srcRows = Array(4, 6, 8, 10, 12, 15, 16, 22, 35, 36, 37, 38)
    wsName = "Sheet1" 'Not "Table1", which is probably a ListObject Table name
    Set thisWS = ThisWorkbook.Worksheets(wsName)
    foldr = "C:MultiPD TestForms"
    ext = ".xlsx"
    srcFile = Dir(foldr & "*" & ext)
    Dim srcWB As Workbook, srcWS As Worksheet, i As Long, j As Long
    i = 1
    Application.ScreenUpdating = False
    Do While Len(srcFile) > 0
        Set srcWB = Workbooks.Open(Filename:=foldr & srcFile, ReadOnly:=True)
        Set srcWS = srcWB.Worksheets(wsName)
        For j = 1 To UBound(srcRows) + 1
            thisWS.Cells(i, j).Value2 = srcWS.Cells(srcRows(j - 1), SRC_COL).Value2
        Next
        i = i + 1
        srcWB.Close False
        srcFile = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

---

输出：

ColA    ColB    ColC    ColD    ColE    ColF    ColG    ColH    ColI    ColJ    ColK    ColL
-----   -----   -----   -----   -----   -----   -----   -----   -----   -----   -----   -----
S1C4    S1C6    S1C8    S1C10   S1C12   S1C15   S1C16   S1C22   S1C35   S1C36   S1C37   S1C38
S2C4    S2C6    S2C8    S2C10   S2C12   S2C15   S2C16   S2C22   S2C35   S2C36   S2C37   S2C38
S3C4    S3C6    S3C8    S3C10   S3C12   S3C15   S3C16   S3C22   S3C35   S3C36   S3C37   S3C38