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.
 

Some videos you may like

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

VoG

Legend
Joined
Jun 19, 2002
Messages
63,651
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
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
75,543
Office Version
365
Platform
Windows
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
 

Phil1981

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

Phil1981

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

VoG

Legend
Joined
Jun 19, 2002
Messages
63,651
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
 

Watch MrExcel Video

Forum statistics

Threads
1,096,301
Messages
5,449,531
Members
405,569
Latest member
deanro

This Week's Hot Topics

Top