Copy Worksheet and Rename with Cell Value

[Phil1981]

I have a list of employees and I would like code to run on a button click that will copy a template sheet (Blank MAP) rename it from the emp list and continue to do this until it finds a blank cell.

My code works sometimes but when it does it is really slow. There is other code needed to grab the emp name, emp id and paste them into specific cells as well but my focus is on the worksheet creation right now.

Below is the code to create the sheets:

Sub UpdateMAPs()
Application.ScreenUpdating = False
Dim i As Integer
Dim ShName As String
i = 2
Do
Sheets("Team List").Select
ShName = Cells(i, 5).Value
Sheets("Blank MAP").Select
Sheets("Blank MAP").Copy Before:=Sheets("Blank MAP")
Sheets("Blank MAP (2)").Name = ShName
i = i + 1
Loop Until IsEmpty(Cells(i, 5).Value)
End Sub

As you can tell I am fairly new to vba so the code might be sloppy.

 

[VoG]

Try

Sub UpdateMAPs()
Dim LR As Long, i As Long
Application.ScreenUpdating = False
With Sheets("Team List")
    LR = .Range("E" & Rows.Count).End(xlUp).Row
    For i = 2 To LR
        Worksheets.Add(before:=Worksheets("Blank MAP")).Name = .Range("E" & i).Value
    Next i
End With
Application.ScreenUpdating = True
End Sub

 

[Norie]

Try this.

Option Explicit
 
Sub UpdateMAPs()
Dim wsMAP As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim ShName As String
 
    Application.ScreenUpdating = False
 
    Set rng = Sheets("Team List").Range("E2")
 
    Set wsMAP = Sheets("Blank MAP")
 
    While rng.Value <> ""

        ShName = rng.Value
 
        wsMAP.Copy Before:=wsMAP
 
        Set wsNew = Sheets(wsMAP.Index - 1)
 
        wsNew.Name = ShName
 
        Set rng = rng.Offset(1)

    Wend
 
End Sub

 

[Phil1981]

Try

Sub UpdateMAPs()
Dim LR As Long, i As Long
Application.ScreenUpdating = False
With Sheets("Team List")
    LR = .Range("E" & Rows.Count).End(xlUp).Row
    For i = 2 To LR
        Worksheets.Add(before:=Worksheets("Blank MAP")).Name = .Range("E" & i).Value
    Next i
End With
Application.ScreenUpdating = True
End Sub

Your code works beautifully to create the sheets, but I need them to be a copy of the Blank MAP sheet which it does not do.

 

[Phil1981]

Try this.

Option Explicit
 
Sub UpdateMAPs()
Dim wsMAP As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim ShName As String
 
    Application.ScreenUpdating = False
 
    Set rng = Sheets("Team List").Range("E2")
 
    Set wsMAP = Sheets("Blank MAP")
 
    While rng.Value <> ""
 
        ShName = rng.Value
 
        wsMAP.Copy Before:=wsMAP
 
        Set wsNew = Sheets(wsMAP.Index - 1)
 
        wsNew.Name = ShName
 
        Set rng = rng.Offset(1)
 
    Wend
 
End Sub

Norie

Your code just errors for me on line

wsMAP.Copy Before:=wsMAP

 

[VoG]

Try

Sub UpdateMAPs()
Dim LR As Long, i As Long
Application.ScreenUpdating = False
With Sheets("Team List")
    LR = .Range("E" & Rows.Count).End(xlUp).Row
    For i = 2 To LR
        Sheets("Blank MAP").Copy Before:=Sheets("Blank MAP")
        ActiveSheet.Name = .Range("E" & i).Value
    Next i
End With
Application.ScreenUpdating = True
End Sub

 

[Phil1981]

worked like a charm ... thank you =)

 

[Drrellik]

I searched the forum and found this old post and it is exactly what I need. However, I can not make it work.
I have two sheets in my WB I changed their names to match Team List and Blank MAP
I am sitting on Team list in cell E2 and I call the macro using Alt+F8 and hit run.

I get a run time error 1004 on ActiveSheet.Name = .Range("E" & i).Value

I have a range of Dates in E2:E300 that I want the new Blank MAP (template) to be renamed as they are created.

Mar-1 Mar-2 Mar-3......

What am I doing wrong?

 

[Fluff]

Try

ActiveSheet.Name = Format(.Range("E" & i).Value, "mmm-d")

 

[Drrellik]

That Worked took about 20 seconds to finish thinking but created all the sheets TYVM