Macro to copy template, named based on cell value in order & allowing data to be added to original list

[dngsullivan]

Hi there,

I'm a complete newbie at VBA, only looked at my first code this week!
After searching many forums (thanks for your help everyone!) I have modified code to work somewhat.

My macro currently copies a template and renames it based on data on my "estimate" sheet, what I need help with is:

1. How do I get the sheets to add in the same order of the data - it currently adds it in backwards (eg sheets appear as Estimate, Room4, Room3, Room2, Room1, Template - I would like it to be Estimate, Room 1,2,3,4, Template)

2. If after the macro has been run, I want to add to the list (eg. Room 5 & Room6), how can I get it to run the macro but ignore sheets already added. I currently receive "RTE 1004: That name is already taken. Try a different one"

3. If possible, can this macro be modified and assigned to buttons next to each room name, so I can create a sheet individually - this may help me with question 2 above.
​

 Sub NewSheets()
    Dim i As Integer
    Dim ws As Worksheet
    Dim sh As Worksheet
    Set ws = Sheets("Template")
    Set sh = Sheets("Estimate")
    Application.ScreenUpdating = 0
     
    For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
        Sheets("Template").Copy After:=sh
        ActiveSheet.Name = sh.Range("A" & i).Value
    Next i
End Sub

Thanks in advance!

 

[Takae]

Re: Macro to copy template, named based on cell value in order & allowing data to be added to originl list

Assuming the list in columnA of Sheets("Estimate").
The first loop makes a virtual array which is not duplicate worksheet names.
The second loop judges if the name (in columnA of Estimate) is in the virtual array or not. Then if the name is not in the list, it copies Template sheet.
Please try this code.

Sub NewSheets()
Dim Dic, w, i As Long, buf As String
Dim sh As Worksheet
Set Dic = CreateObject("Scripting.Dictionary")
Set sh = Sheets("Estimate")
For Each w In Worksheets
    buf = w.Name
    If Not Dic.Exists(buf) Then
        Dic.Add buf, buf
    End If
Next
With sh
    For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row
        buf = .cells(i, 1).Value
        If Not Dic.Exists(buf) Then
            Dic.Add buf, buf
            Sheets("Template").copy After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = .Range("A" & i).Value
        End If
    Next
End With
Set Dic = Nothing
End Sub

 

[dmt32]

Hi,
welcome to forum

see if this update to your code does what you want

Sub NewSheets()
    Dim i As Long
    Dim wsTemplate As Worksheet, wsEstimate As Worksheet
    Dim wsNew As Worksheet
    
    Set wsTemplate = Sheets("Template")
    Set wsEstimate = Sheets("Estimate")
    Application.ScreenUpdating = 0
    
    On Error Resume Next
    
    With wsEstimate
    For i = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
        With .Range("A" & i)
        If Len(.Text) > 0 Then
            Set wsNew = Worksheets(.Text)
            If wsNew Is Nothing Then
                wsTemplate.Copy After:=Worksheets(Worksheets.Count)
                Set wsNew = ActiveSheet
                wsNew.Name = .Text
                Err.Clear
            End If
        End If
        End With
        Set wsNew = Nothing
    Next i
        .Activate
    End With
End Sub

Dave

 

[dngsullivan]

Thanks so much Dave, this worked perfectly

Hi,
welcome to forum

see if this update to your code does what you want

Sub NewSheets()
    Dim i As Long
    Dim wsTemplate As Worksheet, wsEstimate As Worksheet
    Dim wsNew As Worksheet
    
    Set wsTemplate = Sheets("Template")
    Set wsEstimate = Sheets("Estimate")
    Application.ScreenUpdating = 0
    
    On Error Resume Next
    
    With wsEstimate
    For i = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
        With .Range("A" & i)
        If Len(.Text) > 0 Then
            Set wsNew = Worksheets(.Text)
            If wsNew Is Nothing Then
                wsTemplate.Copy After:=Worksheets(Worksheets.Count)
                Set wsNew = ActiveSheet
                wsNew.Name = .Text
                Err.Clear
            End If
        End If
        End With
        Set wsNew = Nothing
    Next i
        .Activate
    End With
End Sub

Dave

 

[dngsullivan]

Re: Macro to copy template, named based on cell value in order & allowing data to be added to originl list

Thanks Takae,

it worked adding the sheets, however if a line/cell value was deleted and then the macro re-run, I received a run time error.

I have solved the problem using the code provided by dmt32 below.
Really appreciate your time though

 

[dmt32]

Thanks so much Dave, this worked perfectly

Hi,
glad code update worked ok for you.

After I posted thought that if you would like to display a msgbox to show all new sheets added

updated code would be as follows:

Sub NewSheets()
    Dim i As Long
    Dim wsTemplate As Worksheet, wsEstimate As Worksheet
    Dim wsNew As Worksheet
    Dim msg As String
    
    Set wsTemplate = Sheets("Template")
    Set wsEstimate = Sheets("Estimate")
    msg = "Following Sheets Have Been Added:" & Chr(10)
    
    
    Application.ScreenUpdating = False
    
    On Error Resume Next
    With wsEstimate
    For i = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
        With .Range("A" & i)
        If Len(.Text) > 0 Then
            Set wsNew = Worksheets(.Text)
            If wsNew Is Nothing Then
                wsTemplate.Copy After:=Worksheets(Worksheets.Count)
                Set wsNew = ActiveSheet
                wsNew.Name = .Text
                msg = msg & .Text & Chr(10)
                Err.Clear
            End If
        End If
        End With
        Set wsNew = Nothing
    Next i
        .Activate
    End With
    On Error GoTo 0
    
    Application.ScreenUpdating = True
    If Len(Mid(msg, 35)) > 0 Then MsgBox msg, 48, "New Sheets"
End Sub

Good luck with your new venture in to VBA - there are plenty on this board to offer advice & guidance should you need it.

Coding is a personal thing & each person will have their preferred approach but have a read here:VBA Development Best Practices
for some guidance you may find helpful..


Many thanks for feedback

Dave.