Заполнение другого листа с использованием ключевых слов [дубликат]

Вот общая модель (сильно прокомментированная), которая должна создавать листы ваших отдельных агентов. Это копирует исходный рабочий лист и удаляет информацию, которая не относится к каждому отдельному агенту.

Код модуля1

Option Explicit

Sub agentWorksheets()
    Dim d As Long, agnt As Variant, vAGNTs As Variant, dAGNTs As Object
    Dim wsn As String, wb As Workbook

    'set special application environment
    'appTGGL bTGGL:=False   'uncomment this after debuging is complete
    Set wb = ThisWorkbook '<~~ set to any open workbook or open a closed one
    wsn = "Agents"   '<~~ rename to the right master workbook

    'create the dictionary and
    Set dAGNTs = CreateObject("Scripting.Dictionary")
    dAGNTs.CompareMode = vbTextCompare

    'first the correct workbook
    With wb
        'work with the master worksheet
        With .Worksheets(wsn)
            'get all of the text values from column B
            vAGNTs = .Range(.Cells(6, "B"), .Cells(Rows.Count, "B").End(xlUp)).Value2

            'construct a dictionary of the agents usin unique keys
            For d = LBound(vAGNTs) To UBound(vAGNTs)
                'overwrite method - no check to see if it exists (just want unique list)
                dAGNTs.Item(vAGNTs(d, 1)) = vbNullString
            Next d

        End With

        'loop through the agents' individual worksheets
        'if one does not exist, create it from the master workbook
        For Each agnt In dAGNTs
            'set error control to catch non-existant agent worksheets
            On Error GoTo bm_Need_Agent_WS
            With Worksheets(agnt)
                On Error GoTo bm_Safe_Exit

                'if an agent worksheet did not exist then
                'one has been created with non-associated data removed
                'perform any additional operations here

                'example: today's date in A1
                .Cells(1, "A") = Date

            End With
        Next agnt

    End With

    'slip past agent worksheet creation
    GoTo bm_Safe_Exit

bm_Need_Agent_WS:
    'basic error control for bad worksheet names, etc.
    On Error GoTo 0
    'copy the master worksheet
    wb.Worksheets(wsn).Copy after:=Sheets(Sheets.Count)
    With wb.Worksheets(Sheets.Count)
        'rename the copy to the agent name
        .Name = StrConv(agnt, vbProperCase)
        'turn off any existing AutoFilter
        If .AutoFilterMode Then .AutoFilterMode = False
        'filter on column for everything that isn't the agent
        With .Range(.Cells(5, "B"), .Cells(Rows.Count, "B").End(xlUp))
            .AutoFilter field:=1, Criteria1:="<>" & agnt
            'step off the header row
            With .Resize(.Rows.Count - 1, 1).Offset(1, 0)
                'check if there is anything to remove
                If CBool(Application.Subtotal(103, .Cells)) Then
                    'delete all non-associated information
                    .EntireRow.Delete
                End If
            End With
        End With
        'turn off the AutoFilter we just created
        .AutoFilterMode = False
    End With
    'go back to the thrown error
    Resume

bm_Safe_Exit:
    'reset application environment
    appTGGL

End Sub

'helper sub to set/restore all of the environment settings
Public Sub appTGGL(Optional bTGGL As Boolean = True)
    With Application
        .ScreenUpdating = bTGGL
        .EnableEvents = bTGGL
        .DisplayAlerts = bTGGL
        .Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
        .CutCopyMode = False
        .StatusBar = vbNullString
    End With
    Debug.Print Timer
End Sub

Иногда это просто легче удалить то, что вы не хотите, чем воссоздать многие части того, с чего вы начали.