VBA Macro to add Header arrays and insert 2 rows

[slohman]

I am trying to create price list from data in sheet Products and copy to sheet Price List with 2 rows of headers not the same and then have 2 blanks rows add to each for each rcell.

Each time I try to do this Headers get replaced even though they are not blank with the next and I cant seem to find how to add rows before the next for each rcell begins.

The below image is what I need. TIA

Dim rCell As Range
Dim i As Long
Dim ws As Worksheet

'Set the variables
Set DataSh = ThisWorkbook.Sheets("Products")
Set PriceList = ThisWorkbook.Sheets("Price List")

Set CategoriesAA2 = DataSh.Range(DataSh.Cells(3, 1), DataSh.Cells(Rows.Count, 11).End(xlUp))
    'I went from the cell row3/column6 (or F3) and go down until the last non empty cell

    i = 2

    For Each rCell In CategoriesAA2 'loop through each cell in the range

        If rCell = "Play > Elevate, Play > Multi-Age Combinations, Play" Then
       
        Worksheets("Price List").Cells(1).Resize(1, 5).Value = Array("Play > Elevate, Play > Multi-Age Combinations, Play")
        Worksheets("Price List").Cells(1).Resize(1, 5).Value = Array("Code", "SKU", "Name", "Price", "Hyperlink to Web")

            i = i + 1                                'Row number
            PriceList.Cells(i, 2) = rCell.Offset(0, -8) 
            PriceList.Cells(i, 3) = rCell.Offset(0, -7) 
            PriceList.Cells(i, 4) = rCell.Offset(0, -4)  
            PriceList.Cells(i, 5) = rCell.Offset(0, -3)  

    End If

    Next rCell
           
    For Each rCell In CategoriesAA2 'loop through each cell in the range

        If rCell = "Fitness > Fitness Track"
       
        Worksheets("Price List").Cells(1).Resize(1, 5).Value = Array("Fitness > Fitness Track")
        Worksheets("Price List").Cells(1).Resize(1, 5).Value = Array("Code", "SKU", "Name", "Price", "Hyperlink to Web")

            i = i + 1  
            PriceList.Cells(i, 2) = rCell.Offset(0, -8) 
            PriceList.Cells(i, 3) = rCell.Offset(0, -7) 
            PriceList.Cells(i, 4) = rCell.Offset(0, -4)  
            PriceList.Cells(i, 5) = rCell.Offset(0, -3)  

        End If

    Next rCell
   
    Worksheets("Price List").Activate
    Range("D:D").HorizontalAlignment = xlRight
    Range("C:C").HorizontalAlignment = xlLeft
    Range("D:D").NumberFormat = "$#,##0.00"
    Range("A:F").Font.Size = 10
    Range("A:F").Font.Color = vbBlack
    Range("A:F").Font.FontStyle = "Calibri Light"

End Sub

 

[Herakles]

Can you show us what the Products worksheet looks like and provide us with some data.

Thanks.

 

[slohman]

 

[Herakles]

Can you paste the data instead of an image of the data.

 

[slohman]

How can I do that.

 

[Herakles]

The easiest way although not recommended way is to to highlight the range, copy and then paste it into your post.

In future use XL2BB, the link is in the Mr Excel editor ribbon.

 

[slohman]

ID	Type	SKU	Name	ALP Price	Mark Up%	Vic Sell Price	Hyperlink to Web	SKU		CategoriesAA2
14039	simple	STSW50E	3.5m Swing Double Polished	4362.433	21.00%	5279	blablabla	TRUE		Freestanding > Freestanding Swings, Play
14040	simple	STSW98E	3m Swing Double Polished	4093.793	21.00%	4954	blablabla	TRUE		Freestanding > Freestanding Swings, Play
13988	simple	SE72	Accessible Big Dipper	2821.111	21.00%	3414	blablabla	TRUE		Freestanding > Freestanding Springs & Rockers, Inclusivity > Inclusive Rockers, Play
6146	simple	FS159	Accessible Carousel (PC frame)	18207.46	21.00%	22032	blablabla	TRUE		Freestanding > Freestanding Motion, Inclusivity > Inclusive Motion, Play, Inclusivity > Social Play
14007	simple	SE71	Accessible Dipper	2115.126	21.00%	2560	blablabla	TRUE		Freestanding > Freestanding Springs & Rockers, Inclusivity > Inclusive Rockers, Play
14008	simple	SE70	Accessible Scuttle	2006.382	21.00%	2428	blablabla	TRUE		Freestanding > Freestanding Springs & Rockers, Inclusivity > Inclusive Rockers, Play
1520	simple	FS25	Activity Net 4m	22376.12	8.00%	24167	blablabla	TRUE		Freestanding > Freestanding Static, Play
1522	simple	FS26	Activity Net 6m	31660.36	8.00%	34194	blablabla	TRUE		Freestanding > Freestanding Static, Play
1518	simple	FS81	Activity Net 6m Double	77734.7	8.00%	83954	blablabla	TRUE		Freestanding > Freestanding Static, Play
1644	simple	Aero Walk	Aerobic Walker - Parkfit	Contact SPA	Contact SPA	Contact SPA	blablabla	TRUE		Fitness > ParkFit, Fitness > ParkFit > Cardio, Fitness > ParkFit > Flexibility & Mobility
1704	simple	SE64	Ambulance	11941.554	21.00%	14450	blablabla	TRUE		Freestanding > Freestanding Springs & Rockers, Inclusivity > Inclusive Rockers, Play, Inclusivity > Themed Play
827	simple	OF64AFS	Anvil Table - Aluminium (free standing)	3569.508	20.00%	4284	blablabla	TRUE		Street & Park Furniture, Street & Park Furniture > Tables
790	simple	OF34T	Arbor Bench - Timber	1918.66	20.00%	2303	blablabla	TRUE		Street & Park Furniture, Street & Park Furniture > Seats & Benches
951	simple	FT34	Arched Monkey Bars	2756.159	30.00%	3584	blablabla	TRUE		Fitness > Fitness Track, Fitness
1524	simple	FS94	Arched Net Climber	14872.858	21.00%	17997	blablabla	TRUE		Freestanding > Freestanding Static, Play
935	simple	FT25	Arched Roman Triangles	2774.927	30.00%	3608	blablabla	TRUE		Fitness > Fitness Track
1576	simple	FS65	Argonaut	16437.042	21.00%	19889	blablabla	TRUE		Freestanding > Freestanding Motion, Play, Inclusivity > Social Play
843	simple	LB37	Ascot Bin	2206.804	20.00%	2649	blablabla	TRUE		Street & Park Furniture, Street & Park Furniture > Bins
1612	simple	Back Ext	Back Extension - Parkfit	Contact SPA	Contact SPA	Contact SPA	blablabla	TRUE		Fitness > ParkFit, Fitness > ParkFit > Strength
10736	simple	FS15	Backhoe	1587.161	21.00%	1921	blablabla	TRUE		Freestanding > Freestanding Static, Play, Inclusivity > Themed Play
917	simple	FT11A	Balance Walker	1537.251	30.00%	1999	blablabla	TRUE		Fitness > Fitness Track
1526	simple	FS22	Ball Toss	1253.431	21.00%	1517	blablabla	TRUE		Freestanding > Freestanding Static, Play
1706	simple	SE59	Beach Buggy	13488.58	21.00%	16322	blablabla	TRUE		Freestanding > Freestanding Springs & Rockers, Inclusivity > Inclusive Rockers, Play, Inclusivity > Themed Play
1614	simple	Bench Press	Bench Press - Parkfit	Contact SPA	Contact SPA	Contact SPA	blablabla	TRUE		Fitness > ParkFit, Fitness > ParkFit > Strength
872	simple	SH01	Bibra Shelter	6064.111	20.00%	7277	blablabla	TRUE		Street & Park Furniture, Street & Park Furniture > Shelters
861	simple	BR07	Bike Rail	453.376	20.00%	545		TRUE		Street & Park Furniture, Street & Park Furniture > Bike Racks & Bollards
1708	simple	SE51	Boat Rocker	2072.346	21.00%	2508		TRUE		Freestanding > Freestanding Springs & Rockers, Play, Inclusivity > Themed Play
1660	simple	Body Twist	Body Twist - Parkfit	Contact SPA	Contact SPA	Contact SPA		TRUE		Fitness > ParkFit, Fitness > ParkFit > Flexibility & Mobility
13888	simple	FS157	Bouncer - Rectangle	9431.26	21.00%	11412		TRUE		Freestanding > Freestanding Motion, Play, Inclusivity > Social Play
13877	simple	FS158	Bouncer - Round	9727.74	21.00%	11771		TRUE		Freestanding > Freestanding Motion, Play, Inclusivity > Social Play

 

[Herakles]

Give this a go on a copy of your data.

Private Sub subCreatePriceList()
Dim WsProducts As Worksheet
Dim WsPriceList As Worksheet
Dim lngLastRow  As Long
Dim strCategory As String
Dim i As Integer
Dim rngCategories As Range
Dim rng As Range
Dim intRow As Integer

    ActiveWorkbook.Save
    
    Call subDeleteWorksheet("ProductsCopied")
    Call subDeleteWorksheet("Price List")
    
    ' Create a copy of Products.
    Worksheets("Products").Copy after:=Sheets("Products")
    Application.CutCopyMode = False
    ActiveSheet.Name = "ProductsCopied"
    
    ' Create Price List sheet.
    Worksheets.Add after:=Worksheets("ProductsCopied")
    ActiveSheet.Name = "Price List"
    
    Set WsPriceList = Worksheets("Price List")
    
    Set WsProducts = Worksheets("ProductsCopied")
    WsProducts.Activate
    
    WsProducts.Range("B1").Value = "Code"
    WsProducts.Range("C1").Value = "Temp"
    WsProducts.Range("J1").Value = "Temp2"
    
    Call subDeleteColumn(WsProducts, "ID")
    Call subDeleteColumn(WsProducts, "Mark Up%")
    Call subDeleteColumn(WsProducts, "Vic Sell Price")
    Call subDeleteColumn(WsProducts, "SKU")
    Call subDeleteColumn(WsProducts, "Temp2")
    WsProducts.Range("B1").Value = "SKU"
        
    lngLastRow = WsProducts.Cells(WsProducts.Rows.Count, 1).End(xlUp).Row
    
    Set rngCategories = WsProducts.Range("F1:F" & lngLastRow)
        
    intRow = 1
    
    strCategory = WsProducts.Range("F1")
        
    For i = 2 To WsProducts.Cells(WsProducts.Rows.Count, 1).End(xlUp).Row
    
        If WsProducts.Range("F" & i).Value <> strCategory Then
        
            strCategory = WsProducts.Range("F" & i).Value
            
            Set rng = WsProducts.Cells(i, 1).Resize(WorksheetFunction.CountIf(rngCategories, strCategory), 5)
            
            WsPriceList.Cells(intRow, 1).Value = strCategory
            WsPriceList.Cells(intRow + 1, 1).Resize(1, 5).Value = Array("Code", "SKU", "Name", "ALP Price", "Hyperlink to Web")
            rng.Copy WsPriceList.Cells(intRow + 2, 1)
            intRow = intRow + rng.Rows.Count + 4
            
        End If
        
    Next i
    
    WsProducts.Cells.EntireColumn.AutoFit
    
    For i = 1 To 5
        WsPriceList.Cells(1, i).EntireColumn.ColumnWidth = WsProducts.Cells(1, i).EntireColumn.ColumnWidth
    Next i
    
    WsPriceList.Cells.VerticalAlignment = xlCenter
    
    subDeleteWorksheet ("ProductsCopied")
    
    ActiveWorkbook.Save
        
    MsgBox "Price List Produced", vbOKOnly, "Confirmation"
    
End Sub

Private Sub subDeleteWorksheet(strWorksheet As String)

    Application.DisplayAlerts = False
    On Error Resume Next
    Worksheets(strWorksheet).Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    
End Sub

Private Sub subDeleteColumn(Ws As Worksheet, strHeader As String)
Dim rngFound As Range

    Set rngFound = Ws.Rows(1).Find(strHeader, LookIn:=xlValues)

    If Not rngFound Is Nothing Then
        rngFound.EntireColumn.Delete
    End If

End Sub

 

[slohman]

Thankyou so much that has saved me days of work. Much appreciated

 

[slohman]

Is there a way of saving the pricing as values not the formulas in column d (Vic Pricing), also the macro seems to run for a long time before it finishes on Price List is there anything I can do?