如何使用VBA基于两个过滤器将数据复制并粘贴到n个新工作簿中？

Question

我的目标是将 1 个主工作簿中的数据复制并粘贴到 n 个单独的工作簿中。

用户应该能够在主控中选择一个“办公桌”，然后触发为该办公桌中的每个人创建 X 数量的工作簿 （每个接收者都不允许看到其他人的数据，这就是为什么每个Desk的数据必须分开）。

过滤器应满足两个标准：

• 第一个标准是“桌子”。有3个选项（桌子1、桌子2、桌子3）
• 第二个标准是分配到每个办公桌的人员。我在其中一张主表中有一张每张桌子的人员映射表

到目前为止，我只能创建一个显示桌面数据的工作簿，但我需要为每个人进一步拆分此数据：

Option Explicit

 Sub copy_data()

    Dim count_col As Long
    Dim count_row As Long
    Dim RelationSheet As Worksheet
    Dim AccountSheet As Worksheet
    Dim InstructionSheet As Worksheet
    Dim wb As Workbook, sht As Worksheet
    Dim desk As String
    Dim START_CELL As String

    Set InstructionSheet = Sheet2
    Set RelationSheet = Sheet1
    Set AccountSheet = Sheet3
    desk = InstructionSheet.Cells(14, 3).Text
    START_CELL = "B5"

    Set wb = Workbooks.Add
    Set sht = ActiveSheet
    sht.Name = "RELATION LEVEL"

    With RelationSheet.Range(START_CELL)
        .AutoFilter Field:=4, Criteria1:=desk
        .CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
    End With

    sht.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
    sht.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
    
    With ActiveWindow
        If .FreezePanes Then .FreezePanes = False
        .SplitColumn = 1
        .SplitRow = 2
        .FreezePanes = True
    End With

    Application.CutCopyMode = False
    RelationSheet.ShowAllData
    RelationSheet.AutoFilterMode = False

   
End Sub

我不知道如何将第二个过滤器添加到代码中来为每个人创建更多工作簿。

在下面的示例中，选择“Desk 1”然后运行宏（通过按钮）应创建 2 个单独的工作簿；一份给阿纳斯塔西娅，一份给罗布。每份报告的名称应结合办公桌和人员姓名，例如“办公桌_1_阿纳斯塔西娅”。

如果不存在桌子+人员组合，则应生成空报告（= 将表格标题复制到报告中）。

书桌	人
1号桌	阿纳斯塔西娅
1号桌	罗布
办公桌2	汤姆
3号桌	迈克尔
3号桌	索菲亚

我准备了一个带有虚拟数据的 Excel 来更好地说明源数据：

带有示例数据的 Excel

Answer 1

Option Explicit
Sub copy_data()
    Dim RelationSheet As Worksheet
    Dim AccountSheet As Worksheet
    Dim InstructionSheet As Worksheet
    Dim wb As Workbook, sht, desk As String
    Dim rngLookUp As Range, i As Long, sDesk As String, sPerson As String
    Dim arrData, sFile As String, sPath As String
    sPath = ThisWorkbook.Path & "\"
    Set InstructionSheet = Sheet2
    Set RelationSheet = Sheet1
    Set AccountSheet = Sheet3
    desk = InstructionSheet.Cells(14, 3).Text
    If Len(desk) = 0 Then Exit Sub
    ' load lookup table into an array
    With InstructionSheet.Range("M1").CurrentRegion
        arrData = .Resize(.Rows.Count - 1).Offset(1).Value
    End With
    Application.ScreenUpdating = False
    ' loop through lookup table
    For i = LBound(arrData) To UBound(arrData)
        sDesk = arrData(i, 1)
        If sDesk = desk Then ' match desk
            sPerson = arrData(i, 2)
            ' report workbook name
            sFile = Replace(sDesk, " ", "_") & "_" & sPerson & ".xlsx"
            Set wb = Workbooks.Add
            Set sht = ActiveSheet
            sht.Name = RelationSheet.Name
            With RelationSheet.ListObjects(1)
                If .AutoFilter.FilterMode Then
                    .AutoFilter.ShowAllData
                End If
                ' filter desk and person
                .Range.AutoFilter Field:=4, Criteria1:=sDesk
                .Range.AutoFilter Field:=2, Criteria1:=sPerson
                ' copy filtered table
                .Range.SpecialCells(xlCellTypeVisible).Copy sht.Range("A1")
                .AutoFilter.ShowAllData
            End With
            ' add a new sheet for AccountLevel
            Set sht = wb.Sheets.Add
            sht.Name = AccountSheet.Name
            With AccountSheet.ListObjects(1)
                If .AutoFilter.FilterMode Then
                    .AutoFilter.ShowAllData
                End If
                .Range.AutoFilter Field:=1, Criteria1:=sDesk
                .Range.AutoFilter Field:=2, Criteria1:=sPerson
                .Range.SpecialCells(xlCellTypeVisible).Copy sht.Range("A1")
                .AutoFilter.ShowAllData
            End With
            Application.DisplayAlerts = False
            ' save report, overwrite if exists
            wb.SaveAs sPath & sFile
            Application.DisplayAlerts = True
            wb.Close
        End If
    Next i
    Application.ScreenUpdating = True
    MsgBox "Done"
End Sub