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除外）对每个工作表名称使用AutoFilter，并一次复制所有行未分配给特定工作表的所有行都将复制到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

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

1 个答案: