VBA: Delete rows if...

[cdrobinson83]

Hello,

I am trying to write something that will delete rows based on certain criteria. Based on the below, if "C" is "EXCHANGE_REPORTING_NUMBER" and "F" AND "G" are both zero, I want to delete that row and any row beneath it that shares the same details in "B" and "D". So for this case, the end result I'm looking for is for rows 2, 3, and 4 to be deleted and rows 5, 6, 7, and 8 to remain untouched. Is anyone able to help with this?

 

[James006]

Hi,
You can turn on your macro recorder .... and go through your process once ... using Autofilter

 

[Alex Blakenburg]

Hi,
You can turn on your macro recorder .... and go through your process once ... using Autofilter

There is a little more to it than that, the section header row identifies which section to delete but the whole section then needs to be deleted.
Autofilter is only going to delete the section header.

 

[Alex Blakenburg]

On a copy of your workbook give this a try.

Sub DeleteZeroSections()

    Dim shtData As Worksheet
    Dim rngData As Range
    Dim arrData As Variant
    Dim rowLast As Long, colLast As Long, colNext As Long
    Dim colIdxLast As Long
    Dim i As Long
    
    Set shtData = ActiveSheet
    With shtData
        rowLast = .Cells(Rows.Count, "B").End(xlUp).Row
        colLast = .Cells(1, Columns.Count).End(xlToLeft).Column
        colNext = colLast + 1
        Set rngData = .Range(.Cells(2, "A"), .Cells(rowLast, colLast))
        arrData = rngData.Value2
        ReDim Preserve arrData(1 To UBound(arrData, 1), 1 To UBound(arrData, 2) + 1)    ' This leaves the additional column empty
    End With
    
    colIdxLast = UBound(arrData, 2)
    For i = 1 To UBound(arrData)
        If arrData(i, 3) = "EXCHANGE_REPORTING_NUMBER" Then
            If CCur(arrData(i, 6)) = 0 And CCur(arrData(i, 7)) = 0 Then
                arrData(i, colIdxLast) = 1      ' Flag rows for deletion
            End If
        End If
        If i <> 1 Then
            If arrData(i, 2) = arrData(i - 1, 2) And arrData(i, 4) = arrData(i - 1, 4) Then
                arrData(i, colIdxLast) = arrData(i - 1, colIdxLast)    ' Flag rows for deletion
            End If
        End If
    Next i
    
    With rngData.Columns(colNext).Resize(, 1)
        .Value = Application.Index(arrData, 0, colIdxLast)
        .SpecialCells(xlCellTypeConstants, xlNumbers).EntireRow.Delete
    End With
        
End Sub

 

[cdrobinson83]

On a copy of your workbook give this a try.

Sub DeleteZeroSections()

    Dim shtData As Worksheet
    Dim rngData As Range
    Dim arrData As Variant
    Dim rowLast As Long, colLast As Long, colNext As Long
    Dim colIdxLast As Long
    Dim i As Long
   
    Set shtData = ActiveSheet
    With shtData
        rowLast = .Cells(Rows.Count, "B").End(xlUp).Row
        colLast = .Cells(1, Columns.Count).End(xlToLeft).Column
        colNext = colLast + 1
        Set rngData = .Range(.Cells(2, "A"), .Cells(rowLast, colLast))
        arrData = rngData.Value2
        ReDim Preserve arrData(1 To UBound(arrData, 1), 1 To UBound(arrData, 2) + 1)    ' This leaves the additional column empty
    End With
   
    colIdxLast = UBound(arrData, 2)
    For i = 1 To UBound(arrData)
        If arrData(i, 3) = "EXCHANGE_REPORTING_NUMBER" Then
            If CCur(arrData(i, 6)) = 0 And CCur(arrData(i, 7)) = 0 Then
                arrData(i, colIdxLast) = 1      ' Flag rows for deletion
            End If
        End If
        If i <> 1 Then
            If arrData(i, 2) = arrData(i - 1, 2) And arrData(i, 4) = arrData(i - 1, 4) Then
                arrData(i, colIdxLast) = arrData(i - 1, colIdxLast)    ' Flag rows for deletion
            End If
        End If
    Next i
   
    With rngData.Columns(colNext).Resize(, 1)
        .Value = Application.Index(arrData, 0, colIdxLast)
        .SpecialCells(xlCellTypeConstants, xlNumbers).EntireRow.Delete
    End With
       
End Sub

Thank you so much! This worked perfectly.