VBA 代码，用于从其他工作表中提取标题列表的数据。并通过对工作簿中的所有工作表重复相同的操作来编译数据集

Question

我有一本超过 90 张的练习册。每张表包含相应请求号（客户）的数据。每张表包含行 1= 键（配置文件部分 &"_"& 标题）、行 2= 配置文件部分、行 3= 每个部分中的标题，然后是请求编号的数据行（1 行或多行）。我们需要从所有选项卡编译指定标题的数据，并在数据集中一起编译。

1. 我在仪表板表中有一个标题列表（表名称“参数”）。这将被复制到“客户数据集”选项卡的列标题。

2. 目前，我已经编写了删除旧工作表“客户数据集”并创建新工作表的代码，并更新了所需标题的列表（更新标题的灵活性）。

3. 在“客户数据集”的第 3 行中查找标题键，并将其与第一个客户表的第 1 行匹配，然后拉出“客户数据集”选项卡中的列值。寻找其他标题并重复相同的操作。因此，我们将为所有指定标题提供 1 个客户的客户数据行。

4. 现在，需要在所有其他客户选项卡上重复此练习，并且需要将数据附加到“客户数据集”工作表中

   任何其他建议的方法也受到高度赞赏。出于测试目的，我目前仅在 3 张纸上运行代码。
   

在一个工作表中提取选定的参数数据

Sub PullData()
Dim wbcompile As Workbook
Dim wssrc, wsdest As Worksheet
Dim ws_Count As Integer
Dim Par_Count As Integer
Dim Par As ListObject

    Application.DisplayAlerts = False
    Set wbcompile = ActiveWorkbook
    wbcompile.Worksheets("Customer Dataset").Delete
    Application.DisplayAlerts = False
    Sheets.Add After:=wbcompile.Worksheets("Dashboard")
    ActiveSheet.Name = "Customer Dataset"
    Set wsdest = ActiveWorkbook.Sheets("Customer Dataset")
    Sheets("Dashboard").Select
    Set Par = Worksheets("Dashboard").ListObjects("Parameters")
    Par_Count = Par.ListColumns(2).Range.Count
    Application.Goto Reference:="Parameters"
    Selection.Copy
    Sheets("Customer Dataset").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Debug.Print Par_Count
    ws_Count = ActiveWorkbook.Worksheets.Count - 2
    Debug.Print ws_Count

End Sub

Answer 1

类似这样的东西（已编译但未测试）：

Sub PullData()
    Dim wbcompile As Workbook
    Dim wsSrc As Worksheet, wsDest As Worksheet, wsPar As Worksheet '<< every variable needs a type
    Dim loPar As ListObject, arr

    Set wbcompile = ActiveWorkbook
    Set wsPar = wbcompile.Worksheets("Dashboard")
    Set loPar = wsPar.ListObjects("Parameters")
    arr = loPar.DataBodyRange.Value 'get parameters as array
    
    Set wsDest = wbcompile.Worksheets("Customer Dataset")
    wsDest.Cells.ClearContents
    'flip the array and place on summary sheet
    wsDest.Range("A1").Resize(UBound(arr, 2), UBound(arr, 1)).Value = Application.Transpose(arr)
    
    For Each wsSrc In wbcompile.Worksheets
        'extract from this sheet?
        If wsSrc.Name <> wsDest.Name And wsSrc.Name <> wsPar.Name Then
            ExtractData wsSrc, wsDest
        End If
    Next wsSrc
End Sub

Sub ExtractData(wsSrc As Worksheet, wsDest As Worksheet)
    Dim lrSrc As Long, nextRowDest As Long, c As Range, m
    
    lrSrc = LastOccupiedRow(wsSrc)  'last row of data on source sheet
    If lrSrc = 3 Then Exit Sub      'no data
    nextRowDest = LastOccupiedRow(wsDest) + 1 'next row to paste to on summary sheet
    'loop over headers in row1 of source sheet
    For Each c In wsSrc.Range("A1", wsSrc.Cells(1, Columns.Count).End(xlToLeft)).Cells
        m = Application.Match(c.Value, wsDest.Rows(3), 0) 'match on summary sheet row 3?
        If Not IsError(m) Then 'got a match?
            'copy row 4 to last row to the summary sheet
            wsSrc.Range(wsSrc.Cells(4, c.Column), wsSrc.Cells(lrSrc, c.Column)).Copy _
                   wsDest.Cells(nextRowDest, m)
        End If
    Next c
End Sub

Function LastOccupiedRow(ws As Worksheet) As Long
    Dim f As Range
    Set f = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    If Not f Is Nothing Then LastOccupiedRow = f.Row
End Function