Excel Adding Worksheets

Question

I need to create a sub where to create worksheets based off of a list of names in a worksheet named AllCities. The list of city names starts in cell A2. The worksheets need to be named after the cell value in the list, and it should not create any duplicate sheets. This is what I have so far:

Sub addsheets()
Dim myCell As Range
Dim Cities As Range


With Sheets("AllCities")
Set Cities = Sheets("AllCities").Range("A2")
Set Cities = Range(Cities, Cities.End(xlDown))
End With

For Each myCell In Cities
If Not myCell.Value = vbNullString Then
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = myCell.Value
End If
Next myCell

End Sub

Answer 1

It looks like the question is around ensuring duplicates are not created. I could think of two ways to do this but and have chosen what I believe to be the most efficient for this situation.

1. Remember the names (Chosen) - Remember the names of the sheets in a string that can be very quickly checked, would not be the best solution if you had large (25+ in length) city names across thousands of tabs, but at that point I suspect you would have different issues to consider.
2. Create an error handling proc that does the check - You could call out to a second procedure that would check if the sheet existed, this would make for a slower processing time but would be safer if used on a large scale.

Below is your code with a check for duplicates included.

Sub addsheets()
Dim myCell      As Range
Dim Cities      As Range
Dim StrSheets   As String
Dim WkSht       As Excel.Worksheet

With ThisWorkbook.Worksheets("AllCities")
    Set Cities = Range(.Range("A2"), .Range("A2").End(xlDown))
End With

StrSheets = "|"
For Each WkSht In ThisWorkbook.Worksheets
    StrSheets = StrSheets & WkSht.Name & "|"
Next

For Each myCell In Cities
    If Not myCell.Value = vbNullString Then
        If InStr(1, StrSheets, "|" & myCell.Value & "|") = 0 Then
            Sheets.Add After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = myCell.Value
            StrSheets = StrSheets & myCell.Value & "|"
        End If
    End If
Next myCell

End Sub

Answer 2

If you don't want any duplicate then the best thing for you would be to remove the duplicate. If you want the original sheet unchanged then create a copy of the sheet and then remove the duplicates and create sheets.

Answer 3

actually exploiting RemoveDuplicates() method of Range object would ask the very question:

Option Explicit

Sub AddSheets()
    Dim myCell As Range
    Dim Cities As Range

    With Sheets("AllCities")
        Set Cities = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants) '<~~ consider non blank cells of column "A" from cell "A2" down to last non blank cell
        Cities.RemoveDuplicates Columns:=Array(1), Header:=xlNo '<~~ remove duplicates
    End With

    For Each myCell In Cities
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = myCell.Value
    Next myCell

End Sub

provided you don't care all duplicates values are lost for ever!

but it'd leave unhandled two important exceptions:

1) duplicate names with regards to sheets already existing prior to macro executing

2) invalid characters in sheet names

you could handle those with dedicated functions which would give green light to next steps, like follows:

Option Explicit

Sub AddSheets()
    Dim myCell As Range
    Dim Cities As Range

    With Sheets("AllCities")
        Set Cities = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants) '<~~ consider non blank cells of column "A" from cell "A2" down to last non blank cell
        Cities.RemoveDuplicates Columns:=Array(1), Header:=xlNo '<~~ remove duplicates from list
    End With

    For Each myCell In Cities
        If CheckSheetName(myCell.Value) Then '<~~ check for invalid sheet name...
            If CheckSheetDuplicate(ActiveWorkbook, myCell.Value) Then '<~~ ... if valid name then check for duplicates in existent sheets...
                Sheets.Add After:=Sheets(Sheets.Count) '<~~ ... if no duplicates sheets then finally add a new sheet...
                ActiveSheet.Name = myCell.Value'<~~ ... and give it proper name
            End If
        End If
    Next myCell

End Sub


Function CheckSheetName(shtName As String) As Boolean
    Dim invalidChars As Variant
    Dim myChar As Variant

    invalidChars = Array(":", "/", "\", "?", "*", "[", "]")

     'check shtName for forbidden characters
    CheckSheetName = True
    For Each myChar In invalidChars
        If InStr(shtName, myChar) > 0 Then
            CheckSheetName = False
            Exit For
        End If
    Next myChar
End Function

Function CheckSheetDuplicate(wb As Workbook, shtName As String) As Boolean
    CheckSheetDuplicate = True '<~~ set positive check result. it'll be turned to negative in case of problems ..
    On Error Resume Next
    CheckSheetDuplicate = wb.Sheets(shtName) Is Nothing '<~~ set negative check result in case of problems from any attempt to use a sheet with given name:  for instance trying and use it as an object
End Function

of course you could make further enhancements in checking functions and have them:

• correct the name

  for instance removing invalid characters

• admit duplicates

  for instance adding a duplicate name counter at the and of it

Finally here is a very bold sub that (hopefully) consciously exploit the error handling removal to avoid checks and got to the final result

Sub BoldlyAddSheets()
    Dim myCell As Range
    Dim Cities As Range
    Dim mysht As Worksheet
    Dim currentShtName As String

    With Sheets("AllCities")
        Set Cities = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants) '<~~ consider non blank cells of column "A" from cell "A2" down to last non blank cell
    End With

    Application.DisplayAlerts = False '<~~ necessary not to have macro interrupted by any prompts risen by possible Delete() method over sheet objects
    On Error Resume Next '<~~ ignore errors -> you must know what you are doing till the next "On Error GoTo 0" statement!

    For Each myCell In Cities
        Set mysht = Sheets(myCell.Value) '<~~ try setting a sheet object with the current cell value and ...
        If mysht Is Nothing Then '<~~ ...if unsuccessful then there's no sheet with the wanted name already, so let's try adding it
            Sheets.Add After:=Sheets(Sheets.Count) '<~~ 1) add a new sheet
            currentShtName = ActiveSheet.Name '<~~ 2) store new sheet default name, to check for things to possibly go wrong...
            ActiveSheet.Name = myCell.Value '<~~ 3) try setting the new name...
            If ActiveSheet.Name = currentShtName Then ActiveSheet.Delete '<~~ ...if unsuccessful (sheet name with forbidden characters) delete the sheet
        Else
            Set mysht = Nothing '<~~ set it back to Nothing for subsequent loops
        End If
    Next myCell

    Application.DisplayAlerts = True '<~~ at long last ... turn default alerts handling on...
    On Error GoTo 0 '<~~ ... and turn default error handling on, too. this latter just for clarity since "On Error GoTo 0" is automatically done at exiting any sub or function
End Sub

Answer 4

Additional variant based on two assumptions, the first one is that the range of cells with cities might contain the duplicates, and the second one is that for some of the cities listed in a range, the sheet has been added already.

Sub addsheets()

    Dim myCell As Range, Cities As Range, Dic As Object, sh As Worksheet, k
    Set Dic = CreateObject("Scripting.Dictionary"): Dic.CompareMode = vbTextCompare

    With Sheets("AllCities")
        Set Cities = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
    End With

    For Each myCell In Cities
    'if value is non blank and not duplicated in a range of cells then add to dictionary
        If myCell.Value2 <> "" And Not Dic.exists(myCell.Value2) Then
            Dic.Add CStr(myCell.Value2), Nothing
        End If
    Next myCell

    For Each sh In ThisWorkbook.Sheets 
    'if sheet with name listed in Cities already exists then remove name from dictionary
        If Dic.exists(sh.Name) Then Dic.Remove (sh.Name)
    Next sh

    For Each k In Dic
    'add sheets with unique values stored in dictionary
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = k
    Next k

End Sub