Create sheets based on cell value

[mmetzinger]

I have the following code

'---------------------------------------------------------------------------------------------------------
'Create sheets for all agents in column E   V2.0
'--------------------------------------------------------------------------------------------------------
Dim FirstAgent As String
Dim LastAgent As String

    Columns("E:E").Select
    Selection.Find(What:="Agent Name", After:=ActiveCell, LookIn:=xlFormulas _
                , LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=True, SearchFormat:=False).Activate
    FirstAgent = ActiveCell.Row + 1
        
    Selection.Find(What:="Totals", After:=ActiveCell, LookIn:=xlFormulas, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=True, SearchFormat:=False).Activate
    LastAgent = ActiveCell.Row - 1
    
    'Make all the sheets for the agents
    Dim makesheets As Integer
    Do Until makesheets = LastAgent + 1
    Sheets.Add After:=Sheets(Sheets.Count)
    Loop

This part of the code works just fine. What I need now is to take the list of agent names that exist between "FirstAgent" and "LastAgent" and name each of the newly created sheets with that name.

 

[patel45]

Sub a()
'---------------------------------------------------------------------------------------------------------
'Create sheets for all agents in column E   V2.0
'--------------------------------------------------------------------------------------------------------
Dim FirstAgent As String, LastAgent As String

    Columns("E:E").Select
    Selection.Find(What:="Agent Name", After:=ActiveCell, LookIn:=xlFormulas _
                , LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=True, SearchFormat:=False).Activate
    FirstAgent = ActiveCell.Row + 1
        
    Selection.Find(What:="Totals", After:=ActiveCell, LookIn:=xlFormulas, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=True, SearchFormat:=False).Activate
    LastAgent = ActiveCell.Row - 1
    
    'Make all the sheets for the agents
    For arow = FirstAgent To LastAgent
      sheetname = Sheets(1).Cells(arow, 5).Value
      Sheets.Add After:=Sheets(Sheets.Count)
      ActiveSheet.Name = sheetname
    Next
End Sub

 

[Biz]

Untest not sure if this helps.

Sub aBkFix()
    '---------------------------------------------------------------------------------------------------------
    'Create sheets for all agents in column E   V2.0
    '--------------------------------------------------------------------------------------------------------
    Dim FirstAgent As String, LastAgent As String
    Dim aStartTime
    
    'Speeding Up VBA Code
    With Application
        .ScreenUpdating = False 'Prevent screen flickering
        .Calculation = xlCalculationManual 'Preventing calculation
        .DisplayAlerts = False 'Turn OFF alerts
        .EnableEvents = False 'Prevent All Events
    End With
    
    'Start Timer
    aStartTime = Now()
    
    With Columns("E:E")
        .Find(What:="Agent Name", After:=ActiveCell, LookIn:=xlFormulas _
            , LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=True, SearchFormat:=False).Activate
        FirstAgent = ActiveCell.Row + 1
        
        .Find(What:="Totals", After:=ActiveCell, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=True, SearchFormat:=False).Activate
        LastAgent = ActiveCell.Row - 1
        
    End With
    
    'Make all the sheets for the agents
    For arow = FirstAgent To LastAgent
        sheetname = Sheets(1).Cells(arow, 5).Value
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = sheetname
    Next
    
    
    'Speeding Up VBA Code
    With Application
        .ScreenUpdating = True 'Prevent screen flickering
        .Calculation = xlAutomatic 'Preventing calculation
        .DisplayAlerts = True 'Turn OFF alerts
        .EnableEvents = True 'Prevent All Events
    End With
    
    'End Timer
    MsgBox "Time taken: " & Format(Now() - aStartTime, "h:mm:ss"), vbInformation, "Job Done!"
    
End Sub