CODEWITHSUNDEEP
excelvba
Henrik Eckhoff
Henrik Eckhoff

Reputation: 65

VBA: duplicate an entire sheet

I have a workbook with one main index sheet and a template sheet.
I have information in my index sheet.
Each line in the main sheet should generate a new sheet.
I want to duplicate the template with all the data in there, but with a name from each line from main sheet.
I can create the sheets with the right names, but with zero data in them.

This is the VBA code to make a new sheet with the right name. I need to copy all the data into all the new sheets. It comes from this blog post by Oscar Cronquist:

'Name macro
Sub CreateSheets()
    'Dimension variables and declare data types
    Dim rng As Range
    Dim cell As Range

    'Enable error handling
    On Error GoTo Errorhandling

    'Show inputbox to user and prompt for a cell range
    Set rng = Application.InputBox(Prompt:="Select cell range:", _
                                   Title:="Create sheets", _
                                   Default:=Selection.Address, _
                                   Type:=8)
    'Iterate through cells in selected cell range
    For Each cell In rng
        'Check if cell is not empty
        If cell <> "" Then
            'Insert worksheet and name the worksheet based on cell value
            Sheets.Add.Name = cell
        End If
        'Continue with next cell in cell range
    Next cell

'Go here if an error occurs
Errorhandling:

    'Stop macro
End Sub

Upvotes: 1

Views: 264

Answers (1)

VBasic2008
VBasic2008

Reputation: 54983

Create Template Worksheets

Sub CreateTemplateWorksheets()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ash As Object: Set ash = wb.ActiveSheet
    
    Dim lws As Worksheet: Set lws = wb.Worksheets("Main Index")
    Dim lrg As Range
    Set lrg = lws.Range("A2", lws.Cells(lws.Rows.Count, "A").End(xlUp))
    
    Dim sws As Worksheet: Set sws = wb.Worksheets("Template")
    
    Dim lCell As Range
    Dim dws As Worksheet
    Dim dwsCount As Long
    Dim dName As String
    
    For Each lCell In lrg.Cells
        dName = CStr(lCell.Value)
        If Len(dName) > 0 Then
            On Error Resume Next
                Set dws = wb.Worksheets(dName)
            On Error GoTo 0
            If dws Is Nothing Then
                sws.Copy After:=wb.Sheets(wb.Sheets.Count)
                Set dws = ActiveSheet
                dws.Name = dName
                dwsCount = dwsCount + 1
            End If
            Set dws = Nothing
        End If
    Next lCell
    
    ash.Select
    
    MsgBox "Worksheets created: " & dwsCount, vbInformation

End Sub

Upvotes: 2

Related Questions