Copy Worksheet and Rename with Cell Value

Phil1981

New Member
Joined
May 27, 2011
Messages
27
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.
 

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand
Try

Code:
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
 
Upvote 0
Try this.
Code:
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
 
Upvote 0
Try

Code:
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.
 
Upvote 0
Try this.
Code:
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

Code:
wsMAP.Copy Before:=wsMAP
 
Upvote 0
Try

Code:
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
 
Upvote 0
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?
 
Upvote 0
Try
VBA Code:
ActiveSheet.Name = Format(.Range("E" & i).Value, "mmm-d")
 
Upvote 0
That Worked took about 20 seconds to finish thinking but created all the sheets TYVM
 
Upvote 0

Forum statistics

Threads
1,213,528
Messages
6,114,154
Members
448,553
Latest member
slaytonpa

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