时间戳

首页 > 解决方案 > 从具有相似名称的多个工作表中提取相同的数据点

excel - 从具有相似名称的多个工作表中提取相同的数据点

问题描述


我有一个 Excel 工作簿，其中包含具有相似名称的工作表子集：Data(US)、Data(UK)、Data(FR)、Data(ES) 等...（括号中是国家/地区的 ISO 代码数据参考）。
我想从所有这些工作表中提取两个数据点，并将它们作为列表打印在新工作表中以创建报告。
每张纸内部都有相同的结构（见这里的图片：

在此处输入图像描述

这样所有数据点都由行（第 6 行中的“001”、“002”、...）和列（D 列中的“001”、“002”）的坐标标识。
我正在尝试编写执行以下操作的代码：

  1. 打开所有名称如下的工作表：数据（**）
  2. 在工作表内，执行 VLOOKUP 以获取与“001”和“002”行对应的值
  3. 打印在新工作表中提取的数据点，一个接一个地作为 D 列中的列表


这是我到目前为止编写的代码，它仅适用于第一张表（数据（美国）），我将我的问题作为评论包括在内：

Sub ImportDataPoints()
    Dim W As Worksheet, C&, F$
    Dim D As String
    'Take the folder path from cell D1
    D = Worksheets("Input").Range("D1").Value
    On Error Resume Next
    'Target sheet to paste the data
    Set W = ThisWorkbook.Worksheets("Data")
         C = 3
    Application.ScreenUpdating = False
         'Open all workbooks in the folder that contain the following
         F = Dir(D & "*FINANCIALDATA*" & "*.xlsx")
Do Until F = ""
         C = C + 1

    'Open the worksheet "Data(US)" 
    '### QUESTION: How to open all worksheets with similar names like Data(**)? ###
    With Workbooks.Open(D & F).Worksheets("Data(US)")

        'First datapoint to extract. Initial position: cell AA10.
        'Do a VLOOKUP to search the value corresponding to coordinate "001"
        .Range("AA10").FormulaR1C1 = "=VLOOKUP(""001"",C[-23]:C[-1],2,FALSE)"
        'Move to AB10: if the previous value is empty, then give me zero
        .Range("AB10").FormulaR1C1 = "=IF(RC[-1]="""",0,RC[-1])"
        'Copy the value
        .Range("AB10").Copy
        'Paste the value in the Target sheet at row 10, column D
        W.Cells(10, C).PasteSpecial xlPasteValues

        'Do the same for the second datapoint and paste it in the Target sheet at row 11, column D
        .Range("AA10").Offset(1, 0).FormulaR1C1 = "=VLOOKUP(""002"",C[-23]:C[-1],2,FALSE)"
        .Range("AB10").Offset(1, 0).FormulaR1C1 = "=IF(RC[-1]="""",0,RC[-1])"
        .Range("AB10").Offset(1, 0).Copy
        W.Cells(11, C).PasteSpecial xlPasteValues

        '### QUESTION: The macro should continue opening all the other sheets (Data(UK), Data(FR), Data(ES), etc...), 
        '### copying the datapoints 001-002 and pasting them in the same target sheet (column D, continuing from the row 11 onwards...)###

    .Parent.Close False
    End With

    F = Dir
Loop
    Set W = Nothing
    Application.ScreenUpdating = True
End Sub


有人知道如何修复代码吗？或者，如果您能想到任何其他更有效的解决方案，所有建议都会被接受！
提前谢谢了！

标签： excelvba

解决方案

像这样的东西：

Sub ImportDataPoints()
    Dim W As Worksheet, C&, F$
    Dim D As String, wb As Workbook, targetRow As Long, sht As Worksheet

    'Take the folder path from cell D1
    D = Worksheets("Input").Range("D1").Value

    'Target sheet to paste the data
    Set W = ThisWorkbook.Worksheets("Data")
    C = 3
    Application.ScreenUpdating = False
    'Open all workbooks in the folder that contain the following
    F = Dir(D & "*FINANCIALDATA*.xlsx")
    Do Until F = ""
         C = C + 1
         Set wb = Workbooks.Open(D & F)
         targetRow = 10 'summary start row
         For each sht in wb.worksheets
             If sht.Name Like "Data(*)" Then
                 '....
                 'run your code for sheet sht
                 '....   
                 targetRow = targetRow + 2 'next summary row
             End With
         Next sht           
         wb.close True
         F = Dir
    Loop
    Set W = Nothing
    Application.ScreenUpdating = True
End Sub

推荐阅读