Macro creates unwanted duplicate sheets; Need better solution to either a) delete, or b)not even create them in the first place

[bbooen]

Hello!

First time VBA user, first time poster so please excuse any style issues with this post or my code (most of it is CTL V'd anyways).

Situation: I'm creating a database for tracking cases at my work. When a cell in a range gets updated, I have created a Macro to automatically create a new sheet from a template. It works well:

Sub CreateSheets()

Application.DisplayAlerts = False

Dim rng As Range
Set rng = Sheets("Summary").Range("B13:B78") '
Dim wks As Worksheet
Dim i As Long

For Each cell In rng
On Error Resume Next
If cell.Value > 0 Then
Set wks = Sheets.Add(After:=Worksheets(Worksheets.Count), Type:="C:\Users\E316416\Documents\Custom Office Templates\HWCL_template.xltm") 'CHANGE path if needed
wks.Name = cell.Value
wks.Range("A1").Value = cell.Value

End If
Next cell

End Sub

However, when I run the macro again (trying to capture additional updates in the range specified above), the code starts creating sheets called "template", "template (1), "template (2)", etc. which are repeats from the sheets that were created the first time around.

That is, I put test values 1, 2, 3, and 4 in B13:B16, and run the macro. It creates sheets from a template and names them 1, 2, 3, and 4. It's amazing. Now let's say the next day I come in and put test value 5 in B17 and run the code again. The macro will create sheets called template, template (1), template (2), template (3), before it gets to my new update sheet 5.

So my sheets appear in this order:

[1][2][3][4][template][template (1)][template (2)][template (3)][5]

I've been trying to find out how to remedy this for about a week now and finally created an account so I could ask the geniuses on this forum. The closest I got to a solution was a SheetKiller sub, but I'm pretty sure the way I have it formatted just deletes everything after the first duplicate template sheet.

Request: I either need an addition to my sub above that will skip over tabs that have already been created, or I need an addition to this SheetKiller Sub that will only delete names with "template (" in the sheet name.

Thanks. I've spent so much time on this forum and haven't quite found anything exactly like my situation.

Sub SheetKiller()
Dim i As Long
Dim j As Long
j = 0

For i = 1 To Sheets.Count
If Sheets(i).Name = "template" Then
j = i
End If
Next i

If j = 0 Or j = Sheets.Count Then Exit Sub

Application.DisplayAlerts = False
For i = Sheets.Count To j + 1 Step -1
Sheets(i).Delete
Next i
Application.DisplayAlerts = True

End Sub


I don't know how to format my code the cool way like I've seen so I apologize for that.

 

[kalak]

You can try this. It should, if it works for you, prevent the addition of already-named sheets.

Sub CreateSheetsx()

Application.DisplayAlerts = False

Dim rng As Range
Set rng = Sheets("Summary").Range("B13:B78") '
Dim wks As Worksheet
Dim i As Long
Dim dic As Object
Set dic = CreateObject("scripting.dictionary"): dic.comparemode = 1

For Each sht In Worksheets
    If Not dic.exists(sht.Name) Then dic.Add sht.Name, Empty
Next sht

For Each cell In rng
On Error Resume Next
If cell.Value > 0 Then
    If Not dic.exists(cell.Value) Then
        Set wks = Sheets.Add(After:=Worksheets(Worksheets.Count), Type:="C:\Users\E316416\Documents\Custom Office Templates\HWCL_template.xltm") 'CHANGE path if needed
        wks.Name = cell.Value
        wks.Range("A1").Value = cell.Value
    End If
End If
Next cell

End Sub

 

[bbooen]

Dang I'm still having template sheets get created. Thanks for trying! Let me know if you have any other ideas I should look into.

 

[kalak]

Dang I'm still having template sheets get created. Thanks for trying! Let me know if you have any other ideas I should look into.

Perhaps if you could provide a better indication of your data. By a small example perhaps.

You seem to want this:

wks.Name = cell.Value

The code I gave should ensure that a particular whole cell value, such as
Template37
cannot be used more than once to try to name a new worksheet.

 

[kalak]

On reflection, it looks like may have I missed out a line. In red.
Try this modified version.

Sub CreateSheetsxx()

'Application.DisplayAlerts = False

Dim rng As Range
Set rng = Sheets("Summary").Range("B13:B78") '
Dim wks As Worksheet
Dim i As Long
Dim dic As Object
Set dic = CreateObject("scripting.dictionary"): dic.comparemode = 1

For Each sht In Worksheets
    If Not dic.exists(sht.Name) Then dic.Add sht.Name, Empty
Next sht

For Each cell In rng
On Error Resume Next
If cell.Value > 0 Then
    If Not dic.exists(cell.Value) Then
        Set wks = Sheets.Add(After:=Worksheets(Worksheets.Count), Type:="C:\Users\E316416\Documents\Custom Office Templates\HWCL_template.xltm") 'CHANGE path if needed
        wks.Name = cell.Value
        wks.Range("A1").Value = cell.Value
        dic.Add cell.Value, Empty
    End If
End If
Next cell

End Sub