将行从 1 个源工作表复制到与工作表名称匹配的工作表

Question

我有一个包含多列数据的主工作表。 接下来我还从一个列表中创建了多个工作表。

现在，如果列中的值与所有工作表名称匹配，我想将主工作表中的行复制到相应的工作表，否则复制到“NA”工作表。

以前我只能想到硬编码，但这是不可行的，因为工作表的数量可能会增加到 50+，所以我需要一些帮助来解决这个问题..

'find rows of master sheet
    With sh
        LstR = .Cells(.Rows.Count, "C").End(xlUp).Row    'find last row of column C
        Set rng = .Range("C3:C" & LstR)    'set range to loop
    End With

'start the loop
'loop through, then loop through each C cell in template. if cell.value == worksheet name, copy to respective worksheet... elseif... else copy to NA
For Each c In rng.Cells
    If c = "WEST" Then
            c.EntireRow.Copy wsl1.Cells(wsl1.Rows.Count, "A").End(xlUp).Offset(1)    'copy row to first empty row in WEST

        ElseIf c = "PKM" Then
        c.EntireRow.Copy wsl2.Cells(wsl2.Rows.Count, "A").End(xlUp).Offset(1)

        Else
        c.EntireRow.Copy wsl7.Cells(wsl7.Rows.Count, "A").End(xlUp).Offset(1)

        End If

    Next c

感谢@user9770531，我能够为宏做我想做的事。

但是，现在我想让宏更加灵活。 例如，我在另一个工作表中有这个附加表 ColA_id 和 ColB_group

我不只是将检查工作表名称与 C 列中的值匹配，而是这样做： 如果主文件列 C 匹配“ColA_id”，则将数据复制到相应的“ColB_group”工作表。假设 ColB_group 已用于创建工作表名称。

Answer 1

使用以下代码 - 同一（标准）模块中的所有子组件

它为每个工作表名称搜索Master.ColumnC（Master 和 NA 除外）
对每个工作表名称使用自动筛选，并一次复制所有行
所有未分配给特定工作表的行都将复制到NA

假设工作表NA 已经创建，带有标题

---

Option Explicit

Const NA_WS As String = "NA"    'Create sheet "NA" if it doesn't exist

Public Sub DistributeData()
    Const MASTER_WS As String = "Master"
    Const MASTER_COL As String = "C"    'AutoFilter column in Master sheet

    Dim wb As Workbook
    Set wb = Application.ThisWorkbook
    Dim ws As Worksheet, lr As Long, lc As Long, ur As Range, fCol As Range, done As Range
    With wb.Worksheets(MASTER_WS)
        lr = .Cells(.Rows.Count, MASTER_COL).End(xlUp).Row
        lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
        Set ur = .Range(.Cells(3, 1), .Cells(lr, lc))
        Set fCol = .Range(.Cells(2, MASTER_COL), .Cells(lr, MASTER_COL))
        Set done = .Range(.Cells(1, MASTER_COL), .Cells(2, MASTER_COL))
    End With

    Application.ScreenUpdating = False
    For Each ws In wb.Worksheets
        If ws.Name <> MASTER_WS And ws.Name <> NA_WS Then
            fCol.AutoFilter Field:=1, Criteria1:=ws.Name
            If fCol.SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
                UpdateWs ws, ur
                Set done = Union(done, fCol.SpecialCells(xlCellTypeVisible))
            End If
        End If
    Next
    If wb.Worksheets(MASTER_WS).AutoFilterMode Then
        fCol.AutoFilter
        UpdateNA done, ur
    End If
    Application.ScreenUpdating = True
End Sub

---

Private Sub UpdateWs(ByRef ws As Worksheet, ByRef fromRng As Range)
    fromRng.Copy
    With ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0)
        .PasteSpecial xlPasteAll
    End With
    ws.Activate
    ws.Cells(1).Select
End Sub

Private Sub UpdateNA(ByRef done As Range, ByRef ur As Range)
    done.EntireRow.Hidden = True
    If ur.SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
        UpdateWs ThisWorkbook.Worksheets(NA_WS), ur.SpecialCells(xlCellTypeVisible)
    End If
    done.EntireRow.Hidden = False
    Application.CutCopyMode = False
    ur.Parent.Activate
End Sub