VBA Code needed to insert rows based on pricepoints

[dougs522]

Hi,
I have attached a cut down version of the data I'm trying to sort.
Column A has product, and column B has a Sell price.
I'm stuck on creating the code to look through the list of prices in column B, and insert blank rows to seperate the list into set pricegroups.
Eg. 0 - 499 / 500 - 799 / 800 - 999 / 1000 - 1499 / 1500 - 1999 / 2000 - 2499 / 2500 - 2999 / 3000 - 3499 / 3500 - 3999 / 4000 - 4499 / 4500 - 4999

Any help or advice would be greatly appreciated.

[Paul_Hossler]

I think this is what you wanted

Option Explicit
Sub InsertPricePoints()
    Dim aryPoints As Variant
    
    aryPoints = Array(0, 500, 800, 1000, 1500, 2000, 2500, 3000, 3500, 4000, 4500)
    
    Dim iRow As Long
    
    Application.ScreenUpdating = False
    
    With ActiveSheet
        For iRow = .Range("B3").CurrentRegion.Cells(1, 1).End(xlDown).Row To .Range("B3").Row + 1 Step -1
            If Application.WorksheetFunction.Match(.Cells(iRow, 2).Value, aryPoints, 1) <> Application.WorksheetFunction.Match(.Cells(iRow - 1, 2).Value, aryPoints, 1) Then
                .Rows(iRow).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            End If
        Next iRow
    End With
    Application.ScreenUpdating = True

End Sub

[dougs522]

I think this is what you wanted

Option Explicit
Sub InsertPricePoints()
    Dim aryPoints As Variant
    
    aryPoints = Array(0, 500, 800, 1000, 1500, 2000, 2500, 3000, 3500, 4000, 4500)
    
    Dim iRow As Long
    
    Application.ScreenUpdating = False
    
    With ActiveSheet
        For iRow = .Range("B3").CurrentRegion.Cells(1, 1).End(xlDown).Row To .Range("B3").Row + 1 Step -1
            If Application.WorksheetFunction.Match(.Cells(iRow, 2).Value, aryPoints, 1) <> Application.WorksheetFunction.Match(.Cells(iRow - 1, 2).Value, aryPoints, 1) Then
                .Rows(iRow).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            End If
        Next iRow
    End With
    Application.ScreenUpdating = True

End Sub

Thanks Paul, you're a champion. Love ya work.

[dougs522]

Hi,
I am trying to find a code solution to delete entire row, if they have red color format (255) in Column A (column C has color formatted cells also, but they aren't considered to the rows to be deleted...only the color rows of column A are the basis to delete entire row.)
Have tried numerous solutions, to no avail.

Any help is greatly appreciated.

Regards,
Doug.

[Paul_Hossler]

1. Very similar to first macro. When deleting rows, better to start at bottom and work up

2. You used conditional formatting, but I went to the cell contents to check

Option Explicit
Sub DeleteRed()
    Dim iRow As Long
    
    Application.ScreenUpdating = False
    
    With ActiveSheet
        For iRow = .Range("A3").CurrentRegion.Cells(1, 1).End(xlDown).Row To .Range("A3").Row Step -1
            If InStr(UCase(.Cells(iRow, 1).Value), "RESALE") > 0 Or InStr(UCase(.Cells(iRow, 1).Value), "DEMO") > 0 Then
                .Rows(iRow).Delete
            End If
        Next iRow
    End With
    Application.ScreenUpdating = True
End Sub

[dougs522]

1. Very similar to first macro. When deleting rows, better to start at bottom and work up

2. You used conditional formatting, but I went to the cell contents to check

Option Explicit
Sub DeleteRed()
    Dim iRow As Long
    
    Application.ScreenUpdating = False
    
    With ActiveSheet
        For iRow = .Range("A3").CurrentRegion.Cells(1, 1).End(xlDown).Row To .Range("A3").Row Step -1
            If InStr(UCase(.Cells(iRow, 1).Value), "RESALE") > 0 Or InStr(UCase(.Cells(iRow, 1).Value), "DEMO") > 0 Then
                .Rows(iRow).Delete
            End If
        Next iRow
    End With
    Application.ScreenUpdating = True
End Sub

Thanks Paul, worked a treat.

Doug