PDA

View Full Version : [SOLVED] VBA Code needed to insert rows based on pricepoints



dougs522
08-23-2018, 05:00 PM
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
08-23-2018, 06:05 PM
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
08-23-2018, 08:37 PM
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
08-24-2018, 03:56 AM
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
08-24-2018, 06:00 AM
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
08-25-2018, 06:29 PM
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