Duplicate Active worksheet and name the worksheet based on cell value

DM2 · May 15th 2021

I've seen a number of posts that do most of what I need, but not exactly what i'm looking for.

I'd like to run the VBA on an active worksheet

The VBA would copy the active work sheet and duplicate it and many times as there are names in a column on another spreadsheet.

Worksheet "DATA", Cells A5:A34 contain the names I want to use

Often the 1st cell has the name of the active worksheet so I want to test for that and make sure I don't duplicate it.

I want the duplicate work sheets to appear after the active worksheet.

I've placed the following code on the "DATA" Worksheet:

Code

Private Sub CommandButton1_Click()
    Call CreateWorksheets(Sheets("DATA").Range("A5:A34"))
End Sub

Sub CreateWorksheets(Names_Of_Sheets As Range)
    Dim No_Of_Sheets_to_be_Added As Integer
    Dim Sheet_Name As String
    Dim i As Integer
        
    No_Of_Sheets_to_be_Added = Names_Of_Sheets.Rows.Count
    
    For i = 1 To No_Of_Sheets_to_be_Added
        Sheet_Name = Names_Of_Sheets.Cells(i, 1).Value
        
        'Only add sheet if it doesn't exist already and the name is longer than zero characters
         If (Sheet_Exists(Sheet_Name) = False) And (Sheet_Name <> "") Then
            'Worksheets.Add().Name = Sheet_Name
            ActiveSheet.Copy After:=ActiveWorkbook.Sheets(Worksheets.Count)
        End If
    Next i
End Sub

Display More

I've placed the following code in a module:

Code

Function Sheet_Exists(WorkSheet_Name As String) As Boolean
    Dim Work_sheet As Worksheet
    Sheet_Exists = False
    
    For Each Work_sheet In ThisWorkbook.Worksheets
        If Work_sheet.Name = WorkSheet_Name Then
            Sheet_Exists = True
        End If
    Next
End Function

The line "Worksheets.Add().Name=Sheet-Name", adds new work sheets but doesn't copy the active worksheet

The Line "ActiveSheet.Copy After :=ActiveWorkbook.Sheets(Worksheets.Count)" only duplicates the work sheet and doesn't place it after the active work sheet but rather at the end of the workbook.

DM2 · May 15th 2021

I should clarify, that i'm testing this code with in the VBA editor. The "CommandButton1_Click()" on the DATA worksheet isn't going to work if it's on the DATA tab because that's not the worksheet I want to copy. Will need to put a button on the active work sheet that calls the VBA

**royUK** · May 16th 2021

Try this. Place the code in a Standard Module and callCopySheets from a Forms Button or Shape

Code

'/// used to check if a specific sheet exists
Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

Sub CopySheets()
    Dim rCl As Range
    
    With Worksheets("DATA")
        For Each rCl In .Cells("A5:A34").Cells
            If Not IsEmpty(rCl) Then
                If Not WksExists(rCl.Value2) Then
                ActiveSheet.Copy after:=ThisWorkbook.Worksheets.Count
                ActiveSheet.Name = rCl.Value2
            End If
        Next rCl
    End With
End Sub

Display More

DM2 · May 17th 2021

I'm getting an error on the line

Code

Next rCl

The error is: "Next without For"?

**royUK** · May 17th 2021

Sorry, missed an End If

Code

'/// used to check if a specific sheet exists
Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

Sub CopySheets()
    Dim rCl As Range
    
    With Worksheets("DATA")
        For Each rCl In .Cells("A5:A34").Cells
            If Not IsEmpty(rCl) Then
                If Not WksExists(rCl.Value2) Then
                    ActiveSheet.Copy after:=ThisWorkbook.Worksheets.Count
                    ActiveSheet.Name = rCl.Value2
                End If
            End If
        Next rCl
    End With
End Sub

Display More

DM2 · May 17th 2021

Still getting an error on "Invalid Procedure Call..." for the first "For".

Code

'/// used to check if a specific sheet exists
Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
Sub CopySheets()
    Dim rCl As Range
 
    With Worksheets("DATA")
       For Each rCl In .Cells("A5:A34").Cells
          If Not IsEmpty(rCl) Then
             If Not WksExists(rCl.Value2) Then
             ActiveSheet.Copy after:=ThisWorkbook.Worksheets.Count
             ActiveSheet.Name = rCl.Value2
             End If
          End If
       Next rCl
    End With
End Sub

Display More

**royUK** · May 18th 2021

Try this

Code

'/// used to check if a specific sheet exists
Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
Sub CopySheets()
    Dim rCl As Range
 
    With Worksheets("DATA")
       For Each rCl In .Range("A5:A34").Cells
          If Not IsEmpty(rCl) Then
             If Not WksExists(rCl.Value2) Then
             ActiveSheet.Copy After:=ThisWorkbook.Worksheets(Worksheets.Count)
             ActiveSheet.Name = rCl.Value2
             End If
          End If
       Next rCl
    End With
End Sub

Display More

DM2 · May 18th 2021

That worked...thanks very much

**royUK** · May 18th 2021

Pleased to help

Duplicate Active worksheet and name the worksheet based on cell value

Participate now!

Share