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

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

2 个答案: