Excel Forum

Code: Select all

Sub AddWorkSheets()
    Dim r As Range, rAll As Range, H As Range
    
    On Error Resume Next
    
    ' set range data from reference cells
    With Worksheets("Main")
        Set rAll = .Range("B7", .Range("B65536").End(xlUp)).Offset(-1, 0)
        Set H = .Range("a5:n5")
    End With
      
    ' add sheet base on named cells
    For Each r In rAll
        Worksheets.Add(After:=Worksheets(Worksheets.Count)) _
            .Name = r.Value
        H.Copy Sheets(r.Value).Range("a1:n1")
        r.Offset(0, -1).Resize(1, 14).Copy Sheets(r.Value).Range("a2:n2")
    Next r
End Sub

Code: Select all

Sub Deleteshts()

Dim RowNo As Long, LR As Long
    
With Sheets("main")
       LR = .Cells(.Rows.Count, "B").End(xlUp).Offset(-1, 0).Row
    For RowNo = 6 To LR
   
       ' On Error Resume Next
       ' initialize row name in table for delete shts
        Application.DisplayAlerts = False
        For Each WS In ActiveWorkbook.Worksheets
            If WS.Name <> Sheets("MAIN").Cells(RowNo, "B") Then
                Else
            WS.Visible = xlSheetVisible
            WS.Delete
            End If
        Next WS
        Application.DisplayAlerts = True
    Next

Exit Sub
End With

End Sub

Code: Select all

Sub AddWorkSheets()
    Dim r As Range, rAll As Range, H As Range, F As Range, WS As Worksheet
    Dim RowNo As Long, LR As Long
    
    ' On Error Resume Next
    Application.DisplayAlerts = False
    
    ' initialize row name in table
    For Each WS In ActiveWorkbook.Worksheets
        If WS.Name <> "Main" Then
            WS.Delete
        End If
    Next
    
    ' set range data from reference cells
    With Worksheets("Main")
        Set rAll = .Range("B11", .Range("B65536").End(xlUp)).Offset(-1, 0)
        Set H = .Range("A1:N5") 'set header data
        Set F = [TFD] '.Offset(-1, 0) 'set footer data
    End With
    
    ' add sheet base on named cells
    For Each r In rAll
        Worksheets.Add(After:=Worksheets(Worksheets.Count)) _
            .Name = r.Value
        H.Copy Sheets(r.Value).Range("a1:u1")
        r.Offset(0, -1).Resize(1, 21).Copy Sheets(r.Value).Range("A65536").End(xlUp).Offset(1, 0)  '.Range("a2:n2")
        F.Copy Sheets(r.Value).Range("A12")
    Next r
    
    Application.DisplayAlerts = True
    
End Su

Code: Select all

Sub AddWorkSheets()
    Dim r As Range, rall As Range
    Dim H As Range, H1 As Range, F As Range
    Dim cl As New Collection, sh As Worksheet
    
    ' set range data from reference cells
    With Worksheets("Main")
        Set rall = .Range("B7", .Range("B65536").End(xlUp)).Offset(-1, 0)
        Set H = .Range("A1:N5") 'set header data
        Set H1 = [Ttl] ' Set Total row
        Set F = [TFD] 'set footer data "name & Date"
    End With
    
    On Error Resume Next
    For Each r In rall
        cl.Add r, r
    Next r
    On Error GoTo 0
    
    Application.DisplayAlerts = False
    For Each sh In Worksheets
        If sh.Name <> "Main" Then
            sh.Delete
        End If
    Next sh
    Application.DisplayAlerts = True
    
    For Each Item In cl
        Worksheets.Add(After:=Worksheets(Worksheets.Count)) _
            .Name = Item
    Next Item
    
    ' add sheet base on named cells
    For Each r In rall
        If Sheets(r.Value).Range("a1") = "" Then
            H.Copy Sheets(r.Value).Range("a1:u1") 'head table
        End If
        r.Offset(0, -1).Resize(1, 21).Copy Sheets(r.Value).Range("A65536").End(xlUp).Offset(1, 0)  'name
    Next r
    
    For Each sh In Worksheets
        If sh.Name <> "Main" Then
            H1.Copy sh.Range("A65536").End(xlUp).Offset(1, 0) ' Total
            F.Copy sh.Range("A65536").End(xlUp).Offset(2, 0) 'name & Date
        End If
    Next sh
    
End Sub