VBA Help - Copy and Add Sheet for every unique value

[Bkisley]

Hello Everyone! I have a VBA issue I can not beat and need the experts.
On my "Project Tracker" tab I have a list of names in starting in cell D7 and going down. Names can be duplicated
Currently I have a macro that when clicked, it will look through this range of data, find the unique values, and will add in a tab and rename each tab the unique name.

What I can't seem to do is instead of adding a blank sheet for each unique name, I Need to be able to copy my "Blank Client" tab have that added for each unique name.

In other words, button is clicked, sheet "Blank Client" is copied and pasted to a tab that is added and named for each unique name.

My current Macro is below..... Please make any changes directly in it. I have other little things like add all new sheets at the end, sort names, etc

Sub CreateWorksheets(Names_Of_Sheets As Range)

    Sheets("Project Tracker").Select
    ActiveWorkbook.Worksheets("Project Tracker").ListObjects("ProjectTrackerTable") _
        .sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Project Tracker").ListObjects("ProjectTrackerTable") _
        .sort.SortFields.Add2 Key:=Range( _
        "ProjectTrackerTable[[#All],[Customer Name]]"), SortOn:=xlSortOnValues, _
        Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Project Tracker").ListObjects( _
        "ProjectTrackerTable").sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Dim No_Of_Sheets_to_be_Added As Integer
Dim Sheet_Name As String
Dim i As Integer
Sheets.Add after:=Sheets(Sheets.Count)
No_Of_Sheets_to_be_Added = Names_Of_Sheets.Rows.Count

For i = 1 To No_Of_Sheets_to_be_Added

Sheet_Name = Names_Of_Sheets.Cells(i, 1).Value

'Only add sheet if it doesn't exist already and the name is longer than zero characters
If (Sheet_Exists(Sheet_Name) = False) And (Sheet_Name <> "") Then
    Worksheets.Add().Name = Sheet_Name
   
End If

Next i

Sheets(Sheets.Count).Select
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True

End Sub

Private Sub CommandButton2_Click()
Call CreateWorksheets(Sheets("Project Tracker").Range("D7:D100"))

End Sub

 

[GWteB]

Your code is using a custom Sheet_Exists function. Assuming you do have such a procedure, the code below is likely to do what you want.

Sub CreateWorksheets(Names_Of_Sheets As Range)

    Dim rng As Range, c As Range

    Set rng = Names_Of_Sheets

    With rng.Parent.ListObjects("ProjectTrackerTable")
        .Sort.SortFields.Clear
        .Sort.SortFields.Add2 Key:=Range("ProjectTrackerTable[[#All],[Customer Name]]"), _
                              SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With

    For Each c In rng
        'Only add sheet if it doesn't exist already and the name is longer than zero characters
        If (Sheet_Exists(c.Value) = False) And (c.Value <> "") Then
            With ThisWorkbook
                .Sheets("Blank Client").Copy After:=.Sheets(.Sheets.Count)
                .Sheets(.Sheets.Count).Name = c.Value
            End With
        End If
    Next c

    Application.DisplayAlerts = False
    With ThisWorkbook
        .Sheets(.Sheets.Count).Delete
    End With
    Application.DisplayAlerts = True

End Sub

 

[Bkisley]

@GWteB and anyone.....I have since made an update to my code that makes it cleaner and actually works for what I INTIALLY need. What it is going off the rails is now after the initial tabs are created. This code wants to add a new tab for ALL VALUES in my pivot table. So when I hit the button for a second time to add in another name, the code wants to add the original list of names as a new tab, which (A) I don't want but (B) creates a naming issue and stops my code. I tried turning off the error checking, but when I did that I got "Blank Client2" "Blank Client3"...........

What I need this code to now do is look at the list of names in my pivot table and if any of those names are already a tab name I need the code to do NOTHING. The code should only try to add a tab IF AND ONLY IF the name in my pivot table list is not already a sheet name
Side note...I added in a section for a dynamic hyperlink to the newly created tab in this code as well.

Sub AddNewClient_Click()

Dim i As Long, LastRow As Long, ws As Worksheet
    Sheets("Data Validation").Select
    Range("A2").Select
    ActiveSheet.PivotTables("ClientPivot").PivotFields("Client Name").AutoSort _
        xlAscending, "Client Name"
    ActiveWorkbook.RefreshAll
    Sheets("Data Validation").Activate
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
      
    Sheets("Blank Client").Copy after:=Sheets(Sheets.Count)
    ActiveSheet.Name = Sheets("Data Validation").Cells(i, 1)
        
Next i
    Sheets("Project Tracker").Select
    Range("E7").Select
    ActiveCell.FormulaR1C1 = _
        "=HYPERLINK(CONCATENATE(""#"",""'"",RC[-1],""'!"",""B12""),RC[-1])"
    Range("D7").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, -2).Select

End Sub

 

[GWteB]

What I need this code to now do is look at the list of names in my pivot table and if any of those names are already a tab name I need the code to do NOTHING. The code should only try to add a tab IF AND ONLY IF the name in my pivot table list is not already a sheet name

With a small adjustment, my code does exactly what you want.
I assumed you had the required custom Sheet_Exists function available, apparently that was not the case.
For the sake of completeness:

Function Sheet_Exists(ByVal argWb As Workbook, ByVal argSheetName As String) As Boolean
    Dim oWs As Worksheet
    For Each oWs In argWb
        If StrComp(oWs.Name, argSheetName, vbTextCompare) = 0 Then
            Sheet_Exists = True
            Exit For
        End If
    Next oWs
End Function

Sub CreateWorksheets_r2(Names_Of_Sheets As Range)

    Dim rng As Range, c As Range

    Set rng = Names_Of_Sheets

    With rng.Parent.ListObjects("ProjectTrackerTable")
        .Sort.SortFields.Clear
        .Sort.SortFields.Add2 Key:=Range("ProjectTrackerTable[[#All],[Customer Name]]"), _
                              SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With

    For Each c In rng.SpecialCells(xlCellTypeVisible)
        'Only add sheet if it doesn't exist already and the name is longer than zero characters
        If (Sheet_Exists(c.Parent.Parent, c.Value) = False) And (c.Value <> "") Then
            With ThisWorkbook
                .Sheets("Blank Client").Copy After:=.Sheets(.Sheets.Count)
                .Sheets(.Sheets.Count).Name = c.Value
            End With
        End If
    Next c

    Application.DisplayAlerts = False
    With ThisWorkbook
        .Sheets(.Sheets.Count).Delete
    End With
    Application.DisplayAlerts = True

End Sub

 

[Bkisley]

I can not get this to work. Maybe I sis something wrong. I went to VBA, Insert, new module, pasted your first code, save.
Then I inserted a new form button and pasted the second code. When I click that button I get an error that says object required. When I Debug it, the line "Set rng = Names_Of_Sheets" is highlighted yellow

 

[Bkisley]

I can not get this to work. Maybe I DID something wrong. I went to VBA, Insert, new module, pasted your first code, save.
Then I inserted a new form button and pasted the second code. When I click that button I get an error that says object required. When I Debug it, the line "Set rng = Names_Of_Sheets" is highlighted yellow

***ALSO*** I found this online late tonight that seems to be what I am after. Maybe this is a different way to look at it? Hopefully the above error is an easy fix.

Copy sheet and rename from a list, ignore duplicates - OzGrid Free Excel/VBA Help Forum

Hi all, I am new to the forum. I have been using it for excel help for years and never had a need to ask my own question until now. I have searched high and low for the answer to this. I am sure it is simple, but I cant find it anywhere. I have an…

www.ozgrid.com

Thank you again for your help so far!

 

[GWteB]

You are welcome and thanks for letting me know.
Glad you encountered an alternative that's working for you.

I get an error that says object required. When I Debug it, the line "Set rng = Names_Of_Sheets" is highlighted yellow

This error indicates that the passed on argument isn't a valid range object. My code is a derivative of your post #1 code, which also required a range object as an argument.
In your post #1 code you included this procedure:

Private Sub CommandButton2_Click()
    Call CreateWorksheets(Sheets("Project Tracker").Range("D7:D100"))
End Sub

If Sheets("Project Tracker").Range("D7:D100") does not evaluate to a valid range object the CreateWorksheets procedure will error on the line you experienced.