Create a new sheet for each unique agent and move all data to each sheet

Here is a generic model (heavily commented) that should produce your individual agent worksheets. This copies the original ‘master’ worksheet and removes information that does not pertain to each individual agent.

Module1 code

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

Sometimes it is just easier to remove what you do not want than recreate many parts of what you started with.

Leave a Comment