Create a new worksheet based on range if existing one cannot be found

Question

I am trying to create a new worksheet, by copying the 'Template', if one does not exist.

The names of the sheets are based on Column A (list starting from A5 of the 'Master'). The list in 'Master' will be updated daily.

I check the list for new names by looping through the existing Sheets. If a cell in Column A (Sheet 'Master') already has a worksheet with the name, then do nothing and go to the next cell. If a name in the list is not among the sheetnames of the Workbook, a worksheet would be added (a copy of the 'Template') and named after the cell value.

I am able to create the new worksheets but for every existing worksheet, the macro creates additional worksheets ('template(2)', 'template(3)', 'template(4)', and so on).

What should I do to eliminate those new sheets of 'template(#)'?

Here is my code:

Sub AutoAddSheet()

Dim MyCell As Range, MyRange As Range

Set MyRange = Sheets("Master").Range("A5")
Set MyRange = Range(MyRange, MyRange.End(xlDown))

For Each MyCell In MyRange

    On Error Resume Next

    Sheets("Template").Copy After:=Sheets(Sheets.Count)

    With Sheets(Sheets.Count)
        .Name = MyCell.Value
        .Cells(2, 1) = MyCell.Value

    End With

    On Error GoTo 0

    MyCell.Hyperlinks.Add Anchor:=MyCell, Address:="", SubAddress:="'" & MyCell.Value & "'!A1"

Next MyCell

End Sub

Answer 1

You need to check if the sheet exists first, here's an efficient function I wrote to do so:

Function CheckSheetExists(ByVal name As String)

' checks if a worksheet already exists

Dim retVal As Boolean

retVal = False

For s = 1 To Sheets.Count
    If Sheets(s).name = name Then
        retVal = True
        Exit For
    End If
Next s

CheckSheetExists = retVal

End Function

So, amend your code to this:

If CheckSheetExists(MyCell.Value) = false then

    Sheets("Template").Copy After:=Sheets(Sheets.Count)

    With Sheets(Sheets.Count)
        .Name = MyCell.Value
        .Cells(2, 1) = MyCell.Value

    End With
End If

Answer 2

You could try it in a different way. First, loop through all Worksheets in the workbook and save their names in sheetNames array.

Then, for each cell in your range, you can use the Match function to see if it already exists in your workbook. If the Match fails, it means this MyCell.Value is not found in the worksheets names >> so create it.

Code

Option Explicit

Sub AutoAddSheet()

Dim MyCell As Range, MyRange As Range
Dim sheetNames() As String
Dim ws As Worksheet
Dim i As Integer

Set MyRange = Sheets("Master").Range("A5", Sheets("Master").Range("A5").End(xlDown))

' put all sheet name from Range A5 in "Master" sheet into an array

ReDim sheetNames(1 To 100) ' = Application.Transpose(MyRange.Value)

i = 1
' loop through all worksheets and get their names
For Each ws In Worksheets
    sheetNames(i) = ws.Name

    i = i + 1
Next ws

'resice array to actual number of sheets in workbook
ReDim Preserve sheetNames(1 To i - 1)

For Each MyCell In MyRange.Cells

    ' sheet name not found in workbook sheets array >> create it
    If IsError(Application.Match(MyCell.Value, sheetNames, 0)) Then
        Sheets("Template").Copy After:=Sheets(Sheets.Count)

        With Sheets(Sheets.Count)
            .Name = MyCell.Value
            .Cells(2, 1) = MyCell.Value
        End With

        MyCell.Hyperlinks.Add Anchor:=MyCell, Address:="", SubAddress:="'" & MyCell.Value & "'!A1"

    Else '<-- sheet name exists in array (don't create a new one)
        ' do nothing
    End If
Next MyCell

' ====== Delete the worksheets with (#) section =====
Application.DisplayAlerts = False
For Each ws In Worksheets       
    If ws.Name Like "*(?)*" Then ws.Delete
Next ws
Application.DisplayAlerts = True

End Sub

Answer 3

I just tweaked your code a little to make sure all references were fully qualified. It should be easier to follow and you don't run the risk of Excel getting confused about where to copy from/to.

Tested and works for me

Sub AutoAddSheet()

Dim MyCell As Range, MyRange As Range

Set MyRange = Sheets("Master").Range("A5")
Set MyRange = Range(MyRange, MyRange.End(xlDown))

Dim wksTemplate As Worksheet
Set wksTemplate = ThisWorkbook.Worksheets("Template")

For Each MyCell In MyRange
    wksTemplate.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)

    Dim wsNew As Worksheet
    Set wsNew = ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)

    With wsNew
        .Name = MyCell.Value
        .Cells(2, 1) = MyCell.Value
    End With

    MyCell.Hyperlinks.Add Anchor:=MyCell, Address:="", SubAddress:="'" & MyCell.Value & "'!A1"
Next MyCell

End Sub