如何使用已经循环的子循环遍历多个工作表？

Question

所以我拼凑了这个子项，它在我的工作簿中的所有选项卡中查找特定名称，然后将所有数据复制到下一个空行的单个工作表中。

基本上是组合一堆具有相同列格式的相似工作表。

所以我的问题是如何修改它以遍历多组工作表？目前，这被编码为仅适用于名为“Group1”的工作表并复制到名为“raw_Group1”的单个工作表中。

我如何修改以同时查找“Group2”，...“GroupN”？分组名称实际上并没有编号，而是像“人”“东西”“订单”等。每个组都有不同的列结构和我试图组合的多个工作表。

Sub copy_Group1()
Dim ws As Worksheet
Dim Destws As Worksheet
Dim Last As Long
Dim wsLast As Long
Dim CopyRng As Range
Dim StartRow As Long

'This keeps the screen from updating until the end, makes the macro run faster
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'defines an existing "Raw_Group1" worksheet instead of creating a new one
Set Destws = ActiveWorkbook.Sheets("Raw_Group1")

'clears sheet first, leaving headers
Destws.Rows("2:" & Rows.Count).ClearContents

'Fill in the start row.
StartRow = 2

'Loop through all worksheets and copy the data to the summary worksheet.
For Each ws In ActiveWorkbook.Worksheets
If LCase(ws.Name) Like "group1*" Then

    'Find the last row with data on the summary and source worksheets.
    Last = LastRow(Destws)
    wsLast = LastRow(ws)

    'If source worksheet is not empty and if the last row >= StartRow, copy the range.
    If wsLast > 0 And wsLast >= StartRow Then

        'Specify the range to place the data. Four options for specifying the range
        ''Set CopyRng = sh.Range("A1:G1") 'whole block of columns
        ''Set CopyRng = ws.Range("A1:B" & LastRow) 'specific columns, to the last row
        ''Set CopyRng = ws.Range("B1").CurrentRegion 'uses the current block of data
        Set CopyRng = ws.Range(ws.Rows(StartRow), ws.Rows(wsLast)) 'Set the range starting at row2

        'Test to see whether there are enough rows in the summary worksheet to copy all the data.
        If Last + CopyRng.Rows.Count > Destws.Rows.Count Then
            MsgBox "There are not enough rows in the " & _
            "summary worksheet to place the data."
            GoTo ExitTheSub
        End If

        CopyRng.Copy ' This statement copies values and formats.

        'paste values only
        With CopyRng
            Destws.Cells(Last + 1, "A").Resize(.Rows.Count, _
            .Columns.Count).Value = .Value
        End With
    End If
End If
Next

ExitTheSub:
Application.Goto Destws.Cells(1)

'filter: turns off then on (resets)
If Destws.AutoFilterMode Then Destws.AutoFilterMode = False
Destws.Range("A1").AutoFilter

'AutoFit the column width in the summary sheet.
Destws.Columns.AutoFit

'turns screen updating back on
Application.ScreenUpdating = True

End Sub

Answer 1

考虑通过在宏中设置参数并按照更改的行来概括每个组的工作簿处理。如果某些组需要特定的处理，请为这些特定的参数值使用条件 If 或 Select Case 块：

Sub copy_Group(group_name As Variant, dest_sheet As Variant)

    ...
    Set Destws = ActiveWorkbook.Sheets(dest_sheet)    
    ...
    If LCase(ws.Name) Like group_name & "*" Then
    ...

End Sub

然后在另一个宏中，在调用上述宏时迭代地传递所有组名和目标表对。如果您需要像 Start_Row 这样的其他参数，甚至使用其他数据结构（即集合、字典）而不是匿名嵌套数组，请相应添加。

Sub RunLoop()
    Dim var As Variant

    For Each var In Array(Array("group1", "Raw_Group1"), Array("people", "ppl_dest"), _
                          Array("stuff", "stuff_dest"), Array("orders", "order_dest"), _
                          Array("other", "other_dest"))
        Call copy_Group(var(0), var(1))
    Next var

End Sub

当然，您没有理由不能将此循环嵌入到之前的宏中，但这可能有助于代码组织，甚至是步骤之间的抽象。

Answer 2

嗯...@parfait...所以我在这里尝试了您的建议。它有点工作，但似乎没有将“组名”（第一个“类型”）传递给第一个 if 语句

Sub RunLoop()
    Dim var As Variant
    For Each var In Array( _
        Array("stuff", "Raw_stuff"), _
        Array("people", "Raw_people"), _
        Array("orders", "Raw_orders"))
        Call copy_Group(var(0), var(1)) 'calls sub listed below
    Next var
End Sub

======================

Sub copy_Group(group_name As Variant, dest_sheet As Variant)

Dim ws As Worksheet
    Dim Destws As Worksheet
    Dim Last As Long
    Dim wsLast As Long
    Dim CopyRng As Range
    Dim StartRow As Long

'This keeps the screen from updating until the end, makes the macro run faster
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'defines an existing worksheet instead of creating a new one
Set Destws = ActiveWorkbook.Sheets(dest_sheet)

'clears sheet first, leaving headers
Destws.Rows("2:" & Rows.Count).ClearContents

'Fill in the start row.
StartRow = 2

'Loop through all worksheets and copy the data to the summary worksheet.
For Each ws In ActiveWorkbook.Worksheets
    If LCase(ws.Name) Like group_name & "*" Then

        'Find the last row with data on the summary and source worksheets.
        Last = LastRow(Destws)
        wsLast = LastRow(ws)

        'If source worksheet is not empty and if the last row >= StartRow, copy the range.
        If wsLast > 0 And wsLast >= StartRow Then

            'Specify the range to place the data. Four options for specifying the range
            ''Set CopyRng = sh.Range("A1:G1") 'whole block of columns
            ''Set CopyRng = ws.Range("A1:B" & LastRow) 'specific columns, to the last row
            ''Set CopyRng = ws.Range("B1").CurrentRegion 'uses the current block of data
            Set CopyRng = ws.Range(ws.Rows(StartRow), ws.Rows(wsLast)) 'Set the range starting at row2

            'Test to see whether there are enough rows in the summary worksheet to copy all the data.
            If Last + CopyRng.Rows.Count > Destws.Rows.Count Then
                MsgBox "There are not enough rows in the " & _
                "summary worksheet to place the data."
                GoTo ExitTheSub
            End If

            CopyRng.Copy ' This statement copies values and formats.

            'paste values only
            With CopyRng
                Destws.Cells(Last + 1, "A").Resize(.Rows.Count, _
                .Columns.Count).Value = .Value
            End With
        End If
    End If
Next

ExitTheSub:
    Application.Goto Destws.Cells(1)

'filter: turns off then on (resets)
If Destws.AutoFilterMode Then Destws.AutoFilterMode = False
Destws.Range("A1").AutoFilter

'AutoFit the column width in the summary sheet.
Destws.Columns.AutoFit

'turns screen updating back on
Application.ScreenUpdating = True

End Sub