Duplicating worksheet based on range and changing worksheet name

[Norvascom]

Hi,

I am looking for a macro that would copy a worksheet named "Template"
multiple times. It would create a copy of the worksheet "Template" and
change the name based on cell reported on range B6:B25 (20 worksheets)
of the worksheet "Config".
First worksheet would be named based on cell B6, Second worksheet
based on cell B7...
However, there may not always be 20 worksheets to create as for
instance there may only be data on cells from the range B6:B10 (only 5
worksheets).
Finally, as a title, cell B5 of the newly copied worksheet would equal
the corresponding cell of the "Config" worksheet (on the B6:B25 range)

Thanks in adance for your help.

 

[Gord Dibben]

Give this a try

Sub CreateNameSheets()
' by Dave Peterson with minor mods by Gord Dibben
' List sheetnames required in col A in a sheet: config
' Sub will copy sheets based on the sheet named as: Template
' and name the sheets accordingly

Dim TemplateWks As Worksheet
Dim ListWks As Worksheet
Dim ListRng As Range
Dim myCell As Range

Set TemplateWks = Worksheets("Template")
Set ListWks = Worksheets("config")
With ListWks
Set ListRng = .Range("B6", .Cells(.Rows.Count, "B").End(xlUp))
End With

For Each myCell In ListRng.Cells
TemplateWks.Copy after:=Worksheets(Worksheets.Count)
On Error Resume Next
With ActiveSheet
.Name = myCell.Value
.Range("B5").Value = myCell.Value
End With
If Err.Number <> 0 Then
MsgBox "Please fix: " & ActiveSheet.Name
Err.Clear
End If
On Error GoTo 0
Next myCell

End Sub


Gord Dibben MS Excel MVP

 

[Norvascom]

Give this a try

Sub CreateNameSheets()
' by Dave Peterson  with minor mods by Gord Dibben
' List sheetnames required in col A in a sheet: config
' Sub will copy sheets based on the sheet named as: Template
' and name the sheets accordingly

    Dim TemplateWks As Worksheet
    Dim ListWks As Worksheet
    Dim ListRng As Range
    Dim myCell As Range

    Set TemplateWks = Worksheets("Template")
    Set ListWks = Worksheets("config")
    With ListWks
        Set ListRng = .Range("B6", .Cells(.Rows.Count, "B").End(xlUp))
    End With

    For Each myCell In ListRng.Cells
        TemplateWks.Copy after:=Worksheets(Worksheets.Count)
        On Error Resume Next
        With ActiveSheet
            .Name = myCell.Value
            .Range("B5").Value = myCell.Value
        End With
        If Err.Number <> 0 Then
            MsgBox "Please fix: " & ActiveSheet.Name
            Err.Clear
        End If
        On Error GoTo 0
    Next myCell

End Sub

Gord Dibben     MS Excel MVP







- Show quoted text -

Thanks Gord. It works perfectly.

 

[Gord Dibben]

Thanks Gord. It works perfectly.

Good to hear.................happy to assist.

Thanks to Dave P. for the original macro.


Gord