Create Rows in New Excelsheet based on the values from other cells

[ThanPanag]

Good day to all, appreciate your help on the below issue:

Trying to create a macro that first creates a new sheet naming it based on a selected cell and then apply specific values in the cells of the first row and got stuck to the point where i want to replicate specific values in consequent rows based on the values of other cells.

More specifically, my data looks like this:

Item Code	Small	Medium	Large
49-ITCMIL-5	2​	2​	4​
43-ITCMIL-7	3​	1​	5​
50-ITCPIC-2	0​	3​	0​

The new sheet should look like below (when i choose the item 49-ITCMIL-5)

Size	PO Nr	Customer Name	Delivery Fee	Warehouse
Small
Small
Medium
Medium
Large
Large
Large
Large

The code written so far is the following (be gentle with its format, as i'm rather new in VBA )

'Name CreateNewSheet
Sub CreateNewSheet()

'Set Dimensions
Dim rng As Range
Dim cell As Range

'Show input box to user asking for a cell
Set rng = Application.InputBox(Prompt:="Select cell range:", _
Title:="Create sheets", _
Default:=Selection.Address, Type:=8)

'Creation of the new Sheet
For Each cell In rng
If cell <> "" Then
Sheets.Add.Name = cell
End If

'ApplyHeaders
Range("A1").Value = "Size"
Range("B1").Value = "PO Nr"
Range("C1").Value = "Customer Name"
Range("D1").Value = "Delivery Fee"
Range("E1").Value = "Warehouse"
End Sub

Any recommendations on completing the coding for the requested result would be more than welcomed!
Best regards, ThanPanag

 

[JGordon11]

try:

Sub Templates()
    Dim rng As Range, r As Range, DataSheet As Worksheet
    Set DataSheet = ActiveSheet
    On Error GoTo EH 'if user clicks cancel in the input box
        Set rng = Application.InputBox(Prompt:="Select cell range:", _
            Title:="Create sheets", _
            Default:=Selection.Address, Type:=8)
    On Error GoTo 0
    For Each r In rng
        BuildTableTemplate r
    Next
    DataSheet.Activate
    Exit Sub
EH:
    MsgBox "Operation Canceled"
End Sub

'=======================================================================================================================================

Private Sub BuildTableTemplate(cl As Range)
    Dim s, rows As Long, i As Long, headers, sizes, sizect As Range, j As Long, k As Long
    Dim wse As Boolean, Borders, ubh As Long, ubs As Long, HdrRange As Range, TblRange As Range
    
    'Header text hard-coded to arrays
    headers = Array("", "Size", "PO Nr", "Customer Name", "Delivery Fee", "Warehouse")
    ubh = UBound(headers)
    sizes = Array("", "Small", "Medium", "Large")
    ubs = UBound(sizes)
    
    With cl(1, 1)
    
        'Check for valid selection (assumes Item Codes are in column A - change 1 to a different column number if not column A)
        If Len(.Value) = 0 Or .Column <> 1 Or .Row = 1 Then
            MsgBox "Invalid selection: " & .Address
            Exit Sub
        End If
        
        'check if worksheet already exists - if answer to overwrite is no then exit without doing anything
        wse = WorkSheetExists(.Value)
        If wse Then If MsgBox("Worksheet named " & .Value & " already exists.  Overwrite it?", vbYesNo) = vbNo Then Exit Sub
        
        'Build the template array named tbl
        Set sizect = .Offset(0, 1).Resize(1, 3)
        rows = Application.Sum(sizect)
        ReDim tbl(1 To rows + 1, 1 To 5) As String

        For i = 1 To ubh
            tbl(1, i) = headers(i)
        Next
        k = 2
        For i = 1 To ubs
            For j = 1 To sizect(1, i)
                tbl(k, 1) = sizes(i)
                k = k + 1
            Next
        Next
        
        'clear or create the Item Code worksheet
        If wse Then Worksheets(.Value).Cells.Clear Else Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = .Value
        
        With Sheets(.Value)
            Set TblRange = .[a1].Resize(rows + 1, ubh)
            'Populate template
            TblRange = tbl
            
            'Format Template column widths, headers, and borders
            Set HdrRange = .Range(.Cells(1, 1), .Cells(1, ubh))
            With HdrRange
                With .Font
                    .ThemeColor = xlThemeColorDark1
                    .Bold = True
                End With
                .Interior.Color = RGB(0, 112, 192)
                .ColumnWidth = 14
            End With 'HdrRange
            
            With TblRange
                Borders = Array("", xlEdgeLeft, xlEdgeRight, xlEdgeBottom, xlEdgeTop, xlInsideHorizontal, xlInsideVertical)
                For i = 1 To 6
                    With .Borders(Borders(i))
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                    End With '.Borders(Borders(i))
                Next
            End With 'TblRange
            
        End With 'Sheets(.Value)
        
    End With 'cl(1,1)
    
End Sub

'=======================================================================================================================================

Private Function WorkSheetExists(ws As String) As Boolean
    Dim wsn
    For Each wsn In Worksheets
        If wsn.Name = ws Then
            WorkSheetExists = True
            Exit Function
        End If
    Next
End Function

 

[ThanPanag]

try:

Sub Templates()
    Dim rng As Range, r As Range, DataSheet As Worksheet
    Set DataSheet = ActiveSheet
    On Error GoTo EH 'if user clicks cancel in the input box
        Set rng = Application.InputBox(Prompt:="Select cell range:", _
            Title:="Create sheets", _
            Default:=Selection.Address, Type:=8)
    On Error GoTo 0
    For Each r In rng
        BuildTableTemplate r
    Next
    DataSheet.Activate
    Exit Sub
EH:
    MsgBox "Operation Canceled"
End Sub

'=======================================================================================================================================

Private Sub BuildTableTemplate(cl As Range)
    Dim s, rows As Long, i As Long, headers, sizes, sizect As Range, j As Long, k As Long
    Dim wse As Boolean, Borders, ubh As Long, ubs As Long, HdrRange As Range, TblRange As Range
   
    'Header text hard-coded to arrays
    headers = Array("", "Size", "PO Nr", "Customer Name", "Delivery Fee", "Warehouse")
    ubh = UBound(headers)
    sizes = Array("", "Small", "Medium", "Large")
    ubs = UBound(sizes)
   
    With cl(1, 1)
   
        'Check for valid selection (assumes Item Codes are in column A - change 1 to a different column number if not column A)
        If Len(.Value) = 0 Or .Column <> 1 Or .Row = 1 Then
            MsgBox "Invalid selection: " & .Address
            Exit Sub
        End If
       
        'check if worksheet already exists - if answer to overwrite is no then exit without doing anything
        wse = WorkSheetExists(.Value)
        If wse Then If MsgBox("Worksheet named " & .Value & " already exists.  Overwrite it?", vbYesNo) = vbNo Then Exit Sub
       
        'Build the template array named tbl
        Set sizect = .Offset(0, 1).Resize(1, 3)
        rows = Application.Sum(sizect)
        ReDim tbl(1 To rows + 1, 1 To 5) As String

        For i = 1 To ubh
            tbl(1, i) = headers(i)
        Next
        k = 2
        For i = 1 To ubs
            For j = 1 To sizect(1, i)
                tbl(k, 1) = sizes(i)
                k = k + 1
            Next
        Next
       
        'clear or create the Item Code worksheet
        If wse Then Worksheets(.Value).Cells.Clear Else Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = .Value
       
        With Sheets(.Value)
            Set TblRange = .[a1].Resize(rows + 1, ubh)
            'Populate template
            TblRange = tbl
           
            'Format Template column widths, headers, and borders
            Set HdrRange = .Range(.Cells(1, 1), .Cells(1, ubh))
            With HdrRange
                With .Font
                    .ThemeColor = xlThemeColorDark1
                    .Bold = True
                End With
                .Interior.Color = RGB(0, 112, 192)
                .ColumnWidth = 14
            End With 'HdrRange
           
            With TblRange
                Borders = Array("", xlEdgeLeft, xlEdgeRight, xlEdgeBottom, xlEdgeTop, xlInsideHorizontal, xlInsideVertical)
                For i = 1 To 6
                    With .Borders(Borders(i))
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                    End With '.Borders(Borders(i))
                Next
            End With 'TblRange
           
        End With 'Sheets(.Value)
       
    End With 'cl(1,1)
   
End Sub

'=======================================================================================================================================

Private Function WorkSheetExists(ws As String) As Boolean
    Dim wsn
    For Each wsn In Worksheets
        If wsn.Name = ws Then
            WorkSheetExists = True
            Exit Function
        End If
    Next
End Function

Thank you very much @JGordon11 ! It works perfectly! Best regards, Thanasis