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

 

[slohman]

It seems to not be working as well as first thought it is repeating Name and not putting them in the right categories

Fitness > ParkFit, Fitness > ParkFit > Cardio, Fitness > ParkFit > Flexibility & Mobility
Code	SKU	Name	ALP Price	Hyperlink to Web
simple	Aero Walk	Aerobic Walker - Parkfit	FALSE
simple	SE64	Ambulance	FALSE
simple	OF64AFS	Anvil Table - Aluminium (free standing)	FALSE
Freestanding > Freestanding Springs & Rockers, Inclusivity > Inclusive Rockers, Play, Inclusivity > Themed Play
Code	SKU	Name	ALP Price	Hyperlink to Web
simple	SE64	Ambulance	FALSE
simple	OF64AFS	Anvil Table - Aluminium (free standing)	FALSE
simple	OF34T	Arbor Bench - Timber	FALSE
simple	FT34	Arched Monkey Bars	FALSE
simple	FS94	Arched Net Climber	FALSE
simple	FT25	Arched Roman Triangles	FALSE
simple	FS65	Argonaut	FALSE
Street & Park Furniture, Street & Park Furniture > Tables
Code	SKU	Name	ALP Price	Hyperlink to Web
simple	OF64AFS	Anvil Table - Aluminium (free standing)	FALSE
simple	OF34T	Arbor Bench - Timber	FALSE
simple	FT34	Arched Monkey Bars	FALSE
simple	FS94	Arched Net Climber	FALSE
simple	FT25	Arched Roman Triangles	FALSE
simple	FS65	Argonaut	FALSE

 

[slohman]

The code is not working correctly the names are getting repeated in each header

Freestanding > Freestanding Swings, Play
Code	SKU	Name	ALP Price	Hyperlink to Web
simple	STSW50E	3.5m Swing Double Polished	4362.433	blablabla
simple	STSW98E	3m Swing Double Polished	4093.793	blablabla
simple	SE72	Accessible Big Dipper	2821.111	blablabla
simple	FS159	Accessible Carousel (PC frame)	18207.46	blablabla
simple	SE71	Accessible Dipper	2115.126	blablabla
simple	SE70	Accessible Scuttle	2006.382	blablabla
Freestanding > Freestanding Springs & Rockers, Inclusivity > Inclusive Rockers, Play
Code	SKU	Name	ALP Price	Hyperlink to Web
simple	SE72	Accessible Big Dipper	2821.111	blablabla
simple	FS159	Accessible Carousel (PC frame)	18207.46	blablabla
simple	SE71	Accessible Dipper	2115.126	blablabla
simple	SE70	Accessible Scuttle	2006.382	blablabla
simple	FS25	Activity Net 4m	22376.12	blablabla
Freestanding > Freestanding Motion, Inclusivity > Inclusive Motion, Play, Inclusivity > Social Play
Code	SKU	Name	ALP Price	Hyperlink to Web
simple	FS159	Accessible Carousel (PC frame)	18207.46	blablabla
simple	SE71	Accessible Dipper	2115.126	blablabla
simple	SE70	Accessible Scuttle	2006.382	blablabla
simple	FS25	Activity Net 4m	22376.12	blablabla
simple	FS26	Activity Net 6m	31660.36	blablabla

 

[slohman]

The names seem to be repeating in each heading they should be separated into what is in column F of my data

Freestanding > Freestanding Swings, Play
Code	SKU	Name	ALP Price	Hyperlink to Web
simple	STSW50E	3.5m Swing Double Polished	4362.433	blablabla
simple	STSW98E	3m Swing Double Polished	4093.793	blablabla
simple	SE72	Accessible Big Dipper	2821.111	blablabla
simple	FS159	Accessible Carousel (PC frame)	18207.46	blablabla
simple	SE71	Accessible Dipper	2115.126	blablabla
simple	SE70	Accessible Scuttle	2006.382	blablabla
Freestanding > Freestanding Springs & Rockers, Inclusivity > Inclusive Rockers, Play
Code	SKU	Name	ALP Price	Hyperlink to Web
simple	SE72	Accessible Big Dipper	2821.111	blablabla
simple	FS159	Accessible Carousel (PC frame)	18207.46	blablabla
simple	SE71	Accessible Dipper	2115.126	blablabla
simple	SE70	Accessible Scuttle	2006.382	blablabla
simple	FS25	Activity Net 4m	22376.12	blablabla
Freestanding > Freestanding Motion, Inclusivity > Inclusive Motion, Play, Inclusivity > Social Play
Code	SKU	Name	ALP Price	Hyperlink to Web
simple	FS159	Accessible Carousel (PC frame)	18207.46	blablabla
simple	SE71	Accessible Dipper	2115.126	blablabla
simple	SE70	Accessible Scuttle	2006.382	blablabla
simple	FS25	Activity Net 4m	22376.12	blablabla
simple	FS26	Activity Net 6m	31660.36	blablabla
Freestanding > Freestanding Springs & Rockers, Inclusivity > Inclusive Rockers, Play
Code	SKU	Name	ALP Price	Hyperlink to Web
simple	SE71	Accessible Dipper	2115.126	blablabla
simple	SE70	Accessible Scuttle	2006.382	blablabla
simple	FS25	Activity Net 4m	22376.12	blablabla
simple	FS26	Activity Net 6m	31660.36	blablabla
simple	FS81	Activity Net 6m Double	77734.7	blablabla

 

[Herakles]

I woke up too early yesterday, I had to do something!!

I assumed that the Products sheet is sorted by the CategoriesAA2 column and maybe some other column/s.

As you can probably see from the code, it creates a copy of the Products worksheet and deletes and renames columns in
preparation for populating the Price List worksheet.

If you do not want the source Products worksheet to be sorted then the ProductsCopied worksheet sheet can be sorted.
Let me know.

The ProductsCopied worksheet is deleted at the end of the code.

How many rows of data do you have? This may affect the speed.
This is a way in which this can be speeded up.
How long does it take?

Is it the [Vic Sell Price] column or the [ALP Price] column that you want to be used for the Price column?

Whichever one it is can I suggest adding another column called [Contact SPA] containing a 'Yes' if the price column contains 'Contact SPA'.
The entries of 'Contact SPA' in the price column can then be deleted.
Mixing data types in a column is not always a good idea.

I didn't realise that Column D, [Vic Pricing], is a formula. What is the formula?
Just add this second row of code beneath the first one shown.

    lngLastRow = WsProducts.Cells(WsProducts.Rows.Count, 1).End(xlUp).Row
    
    WsProducts.Range("D2:D" & lngLastRow).Value = WsProducts.Range("D2:D" & lngLastRow).Value

 

[slohman]

Sorry for the late response. Trying to work this out but still have 1 problem.

Copy and Paste is working great and in the order that I need as I'm using autofilter, except after each paste the next part of the macro starts on row 3 or more (how do I get it to start each time on row 2)

I have made a new macro named copy (see attached) which copies the filter into PRICE LIST then deletes the contents out of PRODUCTSCOPIED to start the next autofilter.

Probably not the quickest way to do things!!!

I will be adding more autofilters along the way but the spreadsheet is only roughly 1000 rows.

This is the end result on Price List

Sub FilteredDataSelection10()
Dim wsProducts As Worksheet
Dim wsProductsCopied 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
Dim LastRow As Long, erow As Long


    'ActiveWorkbook.Save
    
    Call subDeleteWorksheet("ProductsCopied")
    Call subDeleteWorksheet("Price List")
    
    Sheets.Add.Name = "ProductsCopied"
    
    ' Create Price List sheet.
    Worksheets.Add after:=Worksheets("ProductsCopied")
    ActiveSheet.Name = "Price List"
    
    Set WsPriceList = Worksheets("Price List")
    
    Set wsProductsCopied = Worksheets("ProductsCopied")
 
    Set wsProducts = ThisWorkbook.Worksheets("Products")
     'wsProducts.Activate
 
    Sheets("Products").Activate
 
     'ws.Activate
    

 'Clear any existing filters
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0

  '1. Apply Filter
   ActiveSheet.Range("A1:ADU5000").AutoFilter Field:=11, Criteria1:="=Play > Essentials*" ' im filtering by anything in col 24 that contains "P24128"

  '2. Copy Rows minus the header
    Application.DisplayAlerts = False

   wsProducts.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy 'copy the AF first
  
   Set rng = wsProducts.UsedRange.Offset(0, 1)
   Set rng = rng.Resize(rng.rows.Count)
  
   rng.Copy
 
  '3. The Sheet & Where you want to paste the filtered data precisely into Sheet x (Sheet 8 in my example)
  Sheets("ProductsCopied").Activate
  lr = ThisWorkbook.Worksheets("ProductsCopied").Cells(1, 1).SpecialCells(xlCellTypeLastCell).Row + 1
  Range("A" & lr).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

  If Range("A2").Value Like "Type" And Range("J3").Value Like "*Play > Essentials*" Then Range("A1").Value = "Play > Essentials"

  Application.DisplayAlerts = True


'4. Clear Filter from original sheet
    On Error Resume Next
    wsProducts.ShowAllData
    On Error GoTo 0
 
    Call Copy
    
    Sheets("ProductsCopied").Cells.Clear
    Range("a1").Select
    
    Sheets("Products").Activate
    ActiveSheet.Range("A1:ADU5000").AutoFilter Field:=11, Criteria1:="=*Swings,*" ' im filtering by anything in col 24 that contains "P24128"

  '2. Copy Rows minus the header
    Application.DisplayAlerts = False

   wsProducts.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy 'copy the AF first
  
   Set rng = wsProducts.UsedRange.Offset(0, 1)
   Set rng = rng.Resize(rng.rows.Count)
  
   rng.Copy
 
  '3. The Sheet & Where you want to paste the filtered data precisely into Sheet x (Sheet 8 in my example)
  Sheets("ProductsCopied").Activate
  lr = ThisWorkbook.Worksheets("ProductsCopied").Cells(1, 1).SpecialCells(xlCellTypeLastCell).Row
  Range("A" & lr).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    If Range("A3").Value Like "Type" And Range("J4").Value Like "*Freestanding > Freestanding Swings, Play*" Then Range("A2").Value = "Freestanding > Swings"
    
  Application.DisplayAlerts = True
 
    Call Copy
 
    Sheets("ProductsCopied").Cells.ClearContents
    Range("a1").Select

    Sheets("Products").Activate
    ActiveSheet.Range("A1:ADU5000").AutoFilter Field:=11, Criteria1:="=*Springs & Rockers,*" ' im filtering by anything in col 24 that contains "P24128"

  '2. Copy Rows minus the header
    Application.DisplayAlerts = False

   wsProducts.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy 'copy the AF first
  
   Set rng = wsProducts.UsedRange.Offset(0, 1)
   Set rng = rng.Resize(rng.rows.Count)
  
   rng.Copy
 
  '3. The Sheet & Where you want to paste the filtered data precisely into Sheet x (Sheet 8 in my example)
  Sheets("ProductsCopied").Activate
  lr = ThisWorkbook.Worksheets("ProductsCopied").Cells(1, 1).SpecialCells(xlCellTypeLastCell).Row
  Range("A" & lr).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    If Range("A4").Value Like "Type" And Range("J5").Value Like "*Freestanding Springs & Rockers, Play*" Then Range("A3").Value = "Freestanding > Springs and Rockers"
    
  Application.DisplayAlerts = True
 
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0

    Call Copy
 
    Sheets("ProductsCopied").Cells.ClearContents
    Range("a1").Select
      
    'Will delete worksheet when macro is correct
    subDeleteWorksheet ("ProductsCopied")
    
    Call subDeleteColumn(WsPriceList, "Mark Up%")
    Call subDeleteColumn(WsPriceList, "ALP Price")
    Call subDeleteColumn(WsPriceList, "SKU and Name Match")
    Call subDeleteColumn(WsPriceList, "Short Descrip H2")
    Call subDeleteColumn(WsPriceList, "Tags AB2")
    Call subDeleteColumn(WsPriceList, "JPG AD2")
    Call subDeleteColumn(WsPriceList, "DWG BD2")
    Call subDeleteColumn(WsPriceList, "PDF BH2")
    Call subDeleteColumn(WsPriceList, "Tech PDF BX2")
    Call subDeleteColumn(WsPriceList, "Focus DE2")
    Call subDeleteColumn(WsPriceList, "CategoriesAA2")
    
    WsPriceList.Cells.EntireColumn.AutoFit

    Range("A:F").Font.Size = 9
    Range("A:F").Font.Color = vbBlack
    Range("A:F").Font.Name = "Calibri Light"
    Range("D:D").HorizontalAlignment = xlRight
    Range("D:D").NumberFormat = "$#,##0.00"
    Range("A1").Select
    'Range("A2:F2").Font.Size = 12
    'Range("A2:F2").Font.Bold = True

    'ActiveSheet.Name = "Price List"
    
    ActiveWorkbook.Save

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 = Worksheets("Price list").rows(3).Find(strHeader, LookIn:=xlValues)

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

End Sub

Play > Essentials
Type	SKU	Name	Vic Sell Price	Hyperlink to Web
simple	SS10-3000	SS10-3000	$4,954.00
Freestanding > Swings
Type	SKU	Name	Vic Sell Price	Hyperlink to Web
simple	STSW50E	3.5m Swing Double Polished	$5,279.00	Get swinging on the Swing
simple	STSW98E	3m Swing Double Polished	$4,954.00
Type	SKU	Name	Vic Sell Price	Hyperlink to Web
simple	SE72	Accessible Big Dipper	$3,414.00
simple	SE71	Accessible Dipper	$2,560.00	Get swinging on the Swing
simple	SE70	Accessible Scuttle	$2,428.00
simple	SE64	Ambulance	$14,450.00
simple	SE73	Zephyr	$2,179.00

Sub Copy()
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet


  Set copySheet = Worksheets("ProductsCopied")
  Set pasteSheet = Worksheets("Price List")


  copySheet.Range("A1:Q700").Copy
  pasteSheet.Cells(rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlValues
  Application.CutCopyMode = False
 
  End Sub