VBA to create Worksheets from Template

daveasu

Board Regular
Joined
Jan 4, 2012
Messages
53
I have a workbook with 2 worksheets. The first worksheet is named "COURSEID" with a list of course IDs, the second worksheet is named "Template" that has formulas. I would like to copy the Template worksheet, and name the copies from a list in COURSEID from A2:A77.

The VBA code below is not naming the worksheets, and it's placing the COURSEID list on each of the copied sheets.

Any suggestions?

Code:
Sub AddSheets()    Dim xRg As Excel.Range
    Dim wSh As Excel.Worksheet
    Dim sh1 As Excel.Worksheet
    Dim wBk As Excel.Workbook
    Set wSh = Sheets("COURSEID")
    Set sh1 = Sheets("Template")
    Set wBk = ActiveWorkbook
    Application.ScreenUpdating = False
    For Each xRg In wSh.Range("A2:A77")
        With wBk
            sh1.Copy After:=Sheets(Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = xRg.Value: wSh.Range("A2:A77") = xRg.Value: ActiveSheet.Range("a1") = xRg.Value
            If Err.Number = 1004 Then
              Debug.Print xRg.Value & " already used as a sheet name"
            End If
            On Error GoTo 0
        End With
    Next xRg
    Application.ScreenUpdating = True
End Sub
 

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.
Delete the part in red.

Code:
Sub AddSheets()    Dim xRg As Excel.Range
    Dim wSh As Excel.Worksheet
    Dim sh1 As Excel.Worksheet
    Dim wBk As Excel.Workbook
    Set wSh = Sheets("COURSEID")
    Set sh1 = Sheets("Template")
    Set wBk = ActiveWorkbook
    Application.ScreenUpdating = False
    For Each xRg In wSh.Range("A2:A77")
        With wBk
            sh1.Copy After:=Sheets(Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = xRg.Value[COLOR="#FF0000"]: wSh.Range("A2:A77") = xRg.Value[/COLOR]: ActiveSheet.Range("a1") = xRg.Value
            If Err.Number = 1004 Then
              Debug.Print xRg.Value & " already used as a sheet name"
            End If
            On Error GoTo 0
        End With
    Next xRg
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
AlphaFrog, that helped! The worksheets are being created, but only the first worksheet is being named with the corresponding A2 cell in the COURSEID worksheet. The rest of the worksheets are named Template (2), Template (3), etc. In each of the new worksheets, cells A2:A7 are being overwritten with blank cells.
 
Upvote 0
AlphaFrog, that helped! The worksheets are being created, but only the first worksheet is being named with the corresponding A2 cell in the COURSEID worksheet. The rest of the worksheets are named Template (2), Template (3), etc. In each of the new worksheets, cells A2:A7 are being overwritten with blank cells.

Actually it's overwriting A7:A77 sorry for the typo. Any suggestions on what I may be doing wrong? Many thanks.
 
Upvote 0
Code:
[COLOR=darkblue]Sub[/COLOR] AddSheets()
    [COLOR=darkblue]Dim[/COLOR] xRg       [COLOR=darkblue]As[/COLOR] Excel.Range
    Application.ScreenUpdating = [COLOR=darkblue]False[/COLOR]
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] xRg [COLOR=darkblue]In[/COLOR] Sheets("COURSEID").Range("A2:A77")
        Sheets("Template").Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = xRg.Value
        ActiveSheet.Range("A1") = xRg.Value
    [COLOR=darkblue]Next[/COLOR] xRg
    Application.ScreenUpdating = [COLOR=darkblue]True[/COLOR]
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]
 
Last edited:
Upvote 0
THANK YOU AlphaFrog! That is just what I needed. This process is now working perfectly. (From a fellow Michigan J fan)
 
Upvote 0

Forum statistics

Threads
1,213,524
Messages
6,114,117
Members
448,549
Latest member
brianhfield

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top