VBA Macro to add Header arrays and insert 2 rows

slohman

Board Regular
Joined
Mar 31, 2012
Messages
110
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

VBA Code:
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
 

Attachments

  • Screenshot 2023-06-01 121031.jpg
    Screenshot 2023-06-01 121031.jpg
    92.4 KB · Views: 15
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
CodeSKUNameALP PriceHyperlink to Web
simpleAero WalkAerobic Walker - ParkfitFALSE
simpleSE64AmbulanceFALSE
simpleOF64AFSAnvil Table - Aluminium (free standing)FALSE
Freestanding > Freestanding Springs & Rockers, Inclusivity > Inclusive Rockers, Play, Inclusivity > Themed Play
CodeSKUNameALP PriceHyperlink to Web
simpleSE64AmbulanceFALSE
simpleOF64AFSAnvil Table - Aluminium (free standing)FALSE
simpleOF34TArbor Bench - TimberFALSE
simpleFT34Arched Monkey BarsFALSE
simpleFS94Arched Net ClimberFALSE
simpleFT25Arched Roman TrianglesFALSE
simpleFS65ArgonautFALSE
Street & Park Furniture, Street & Park Furniture > Tables
CodeSKUNameALP PriceHyperlink to Web
simpleOF64AFSAnvil Table - Aluminium (free standing)FALSE
simpleOF34TArbor Bench - TimberFALSE
simpleFT34Arched Monkey BarsFALSE
simpleFS94Arched Net ClimberFALSE
simpleFT25Arched Roman TrianglesFALSE
simpleFS65ArgonautFALSE
 
Upvote 0

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
The code is not working correctly the names are getting repeated in each header
Freestanding > Freestanding Swings, Play
CodeSKUNameALP PriceHyperlink to Web
simpleSTSW50E3.5m Swing Double Polished4362.433blablabla
simpleSTSW98E3m Swing Double Polished4093.793blablabla
simpleSE72Accessible Big Dipper2821.111blablabla
simpleFS159Accessible Carousel (PC frame)18207.46blablabla
simpleSE71Accessible Dipper2115.126blablabla
simpleSE70Accessible Scuttle2006.382blablabla
Freestanding > Freestanding Springs & Rockers, Inclusivity > Inclusive Rockers, Play
CodeSKUNameALP PriceHyperlink to Web
simpleSE72Accessible Big Dipper2821.111blablabla
simpleFS159Accessible Carousel (PC frame)18207.46blablabla
simpleSE71Accessible Dipper2115.126blablabla
simpleSE70Accessible Scuttle2006.382blablabla
simpleFS25Activity Net 4m22376.12blablabla
Freestanding > Freestanding Motion, Inclusivity > Inclusive Motion, Play, Inclusivity > Social Play
CodeSKUNameALP PriceHyperlink to Web
simpleFS159Accessible Carousel (PC frame)18207.46blablabla
simpleSE71Accessible Dipper2115.126blablabla
simpleSE70Accessible Scuttle2006.382blablabla
simpleFS25Activity Net 4m22376.12blablabla
simpleFS26Activity Net 6m31660.36blablabla
 
Upvote 0
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
CodeSKUNameALP PriceHyperlink to Web
simpleSTSW50E3.5m Swing Double Polished4362.433blablabla
simpleSTSW98E3m Swing Double Polished4093.793blablabla
simpleSE72Accessible Big Dipper2821.111blablabla
simpleFS159Accessible Carousel (PC frame)18207.46blablabla
simpleSE71Accessible Dipper2115.126blablabla
simpleSE70Accessible Scuttle2006.382blablabla
Freestanding > Freestanding Springs & Rockers, Inclusivity > Inclusive Rockers, Play
CodeSKUNameALP PriceHyperlink to Web
simpleSE72Accessible Big Dipper2821.111blablabla
simpleFS159Accessible Carousel (PC frame)18207.46blablabla
simpleSE71Accessible Dipper2115.126blablabla
simpleSE70Accessible Scuttle2006.382blablabla
simpleFS25Activity Net 4m22376.12blablabla
Freestanding > Freestanding Motion, Inclusivity > Inclusive Motion, Play, Inclusivity > Social Play
CodeSKUNameALP PriceHyperlink to Web
simpleFS159Accessible Carousel (PC frame)18207.46blablabla
simpleSE71Accessible Dipper2115.126blablabla
simpleSE70Accessible Scuttle2006.382blablabla
simpleFS25Activity Net 4m22376.12blablabla
simpleFS26Activity Net 6m31660.36blablabla
Freestanding > Freestanding Springs & Rockers, Inclusivity > Inclusive Rockers, Play
CodeSKUNameALP PriceHyperlink to Web
simpleSE71Accessible Dipper2115.126blablabla
simpleSE70Accessible Scuttle2006.382blablabla
simpleFS25Activity Net 4m22376.12blablabla
simpleFS26Activity Net 6m31660.36blablabla
simpleFS81Activity Net 6m Double77734.7blablabla
 
Upvote 0
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.

VBA Code:
    lngLastRow = WsProducts.Cells(WsProducts.Rows.Count, 1).End(xlUp).Row
    
    WsProducts.Range("D2:D" & lngLastRow).Value = WsProducts.Range("D2:D" & lngLastRow).Value
 
Upvote 0
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
VBA Code:
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
TypeSKUNameVic Sell PriceHyperlink to Web
simpleSS10-3000SS10-3000$4,954.00
Freestanding > Swings
TypeSKUNameVic Sell PriceHyperlink to Web
simpleSTSW50E3.5m Swing Double Polished$5,279.00Get swinging on the Swing
simpleSTSW98E3m Swing Double Polished$4,954.00
TypeSKUNameVic Sell PriceHyperlink to Web
simpleSE72Accessible Big Dipper$3,414.00
simpleSE71Accessible Dipper$2,560.00Get swinging on the Swing
simpleSE70Accessible Scuttle$2,428.00
simpleSE64Ambulance$14,450.00
simpleSE73Zephyr$2,179.00
Code:
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
 
Upvote 0

Forum statistics

Threads
1,223,098
Messages
6,170,106
Members
452,302
Latest member
TaMere

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top