Need a macro to delete rows based on multiple conditions

Hello!

I just recently moved into a new job at work and one of my first duties is creating macros. I am woefully inept at this so far and for the most part have been reverse engineering recorded macros to learn.

My problem I am looking at is that I have an array of six codes in COLUMN B that indicate reversals of payments. Once I see one of these codes in this column I need the macro to check the same row for a value in COLUMN C once it finds that value it needs to move up a row and check to see if the same value is in that row. If all three values are true it needs to delete both columns.

Column A (DATES)   Column B (CODES)  Column C (PAYMENTS)
1/1/1990             1(Valid pmt code)                        $200
1/1/1990             REV(reversal code)                      $200
1/1/1990             1                                              $200
1/1/1990             1                                              $523  
1/1/1990             6(also a reversal code)                $523

In this example it would delete rows 1,2,4,5 but leave row 3 intact.

*This is the code I am currently attempting to use.*

Sub Formatting()

    'THIS IS THE CONDITIONAL FORMATTING TO CHECK FOR REVERSALS'
    
    Dim Firstrow As Long
    Dim LastRow As Long
    Dim Lrow As Long
    Dim CalcMode As Long
    Dim ViewMode As Long
    Dim Cell As Range
    Dim Cell1 As String
    Dim Cell2 As String
    Dim Cell3 As String
    
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    With ActiveSheet

        'We select the sheet so we can change the window view
        .Select

        ViewMode = ActiveWindow.View
        ActiveWindow.View = xlNormalView

        'Turn off Page Breaks, we do this for speed
        .DisplayPageBreaks = False

        'Set the first and last row to loop through
        Firstrow = .UsedRange.Cells(1).Row + 1
        LastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
        
        'We loop from Lastrow to Firstrow (bottom to top)
        For Lrow = LastRow To Firstrow Step -1
            
            
            'We check the values in the B column'
            
            With .Cells(Lrow, "A")
    
                If Not IsError(.Value) Then
                Cell1 = .Cells(Lrow, "A").Value
                Cell2 = .Cells(Lrow, "B").Value
                Cell3 = .Cells(Lrow, "C").Value

                If Trim(.Cells(Lrow, "B").Value) = "REV" And .Cells(Lrow - 1, "C").Value = .Cells(Lrow, "C").Value Then
                 Rows(Lrow).EntireRow.Delete
                 Rows(Lrow - 1).EntireRow.Delete
               
                
                End If

                End If

            End With

        Next Lrow

    End With

This is how I would run those tests, read it through and you'll see. The goal here is to delete all the rows at once at the end, so this should be much faster overall.

Option Explicit

Sub DeleteReversals()
Dim delRNG As Range, Rw As Long, LR As Long

LR = Range("A" & Rows.Count).End(xlUp).Row

For Rw = LR To 2 Step -1
    If Range("B" & Rw).Value = 6 Or Range("B" & Rw).Value = "REV" Then
        If Range("C" & Rw).Value = Range("C" & Rw - 1).Value Then
            If delRNG Is Nothing Then
                Set delRNG = Range("A" & Rw - 1).Resize(2)
            Else
                Set delRNG = Union(delRNG, Range("A" & Rw - 1).Resize(2))
            End If
        End If
    End If
Next Rw

If Not delRNG Is Nothing Then delRNG.EntireRow.Delete xlShiftUp

End Sub

For that many, I'd switch to this syntax:

Option Explicit

Sub DeleteReversals()
Dim delRNG As Range, Rw As Long, LR As Long

LR = Range("A" & Rows.Count).End(xlUp).Row

For Rw = LR To 2 Step -1
    Select Case Range("B" & Rw).Value
        Case Is = 200, 201, 202, 203, 204, "REV"
            If Range("C" & Rw).Value = Range("C" & Rw - 1).Value Then
                If delRNG Is Nothing Then
                    Set delRNG = Range("A" & Rw - 1).Resize(2)
                Else
                    Set delRNG = Union(delRNG, Range("A" & Rw - 1).Resize(2))
                End If
            End If
    End Select
Next Rw

If Not delRNG Is Nothing Then delRNG.EntireRow.Delete xlShiftUp

End Sub

When it breaks, and you DEBUG, what is the value of Rw?

The value of RW should never be 1. The loop is running from the last row up to row 2 and stopping.

What is the value of LR? That should always be higher than 2. If it's not, change the line of code above the loop where the LR variable is getting determined, choose a column other than "A".

I got the ranges defined but deleting the rows doesn't work still.

This is the code I have:

Sub DeleteReversals()
Dim delRNG As Range, Rw As Long, LR As Long

LR = Range("A" & Rows.Count).End(xlUp).Row

Rw = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row

For Rw = LR To 3 Step -1
    Select Case Range("B" & Rw).Value
        Case Is = 600, 601, 602, 603, 604, "REV"
            If Range("C" & Rw).Value = Range("C" & Rw - 1).Value Then
                If delRNG Is Nothing Then
                    Set delRNG = Range("A" & Rw - 1).Resize(2)
                Else
                    Set delRNG = Union(delRNG, Range("A" & Rw - 1).Resize(2))
                End If
            End If
    End Select
Next Rw

If Not delRNG Is Nothing Then delRNG.EntireRow.Delete xlShiftUp

End Sub

Also, the value of LR is set as 5000, due to my table range.

Let's see this macro in a sample workbook not doing the right thing....

Try zipping the file you're trying to upload.

The presence of an Excel "Table" is gumming up the works. So, we test for that, remove the table if it's there, run the macro, delete the rows, then put the table back:

Option Explicit

Sub DeleteReversals()
Dim delRNG As Range
Dim Rw As Long
Dim LR As Long
Dim IsTable As Boolean

If ActiveSheet.ListObjects.Count > 0 Then IsTable = True
If IsTable Then ActiveSheet.ListObjects(1).Unlist                            ' convert the table back to a range

LR = Range("A" & Rows.Count).End(xlUp).Row

For Rw = LR To 3 Step -1
    Select Case Range("B" & Rw).Value
        Case Is = 600, 601, 602, 603, 604, "REV"
            If Range("C" & Rw).Value = Range("C" & Rw - 1).Value Then
                If delRNG Is Nothing Then
                    Set delRNG = Range("A" & Rw - 1).Resize(2)
                Else
                    Set delRNG = Union(delRNG, Range("A" & Rw - 1).Resize(2))
                End If
            End If
    End Select
Next Rw

If Not delRNG Is Nothing Then delRNG.EntireRow.Delete xlShiftUp
If IsTable Then ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = "Table1"

End Sub

If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED. Thanks.