Untitled

Sub FilterAndRemoveBlankRows()
    Dim wsReport As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim countryColumns As Variant
    Dim col As Long
    Dim isRowEmpty As Boolean

    ' Set your report worksheet
    Set wsReport = ThisWorkbook.Sheets("Report Sheet") ' Change "Report Sheet" to your destination sheet name

    ' Define the columns for each country (2-column sets for each country)
    countryColumns = Array(Array(5, 6), Array(9, 9), Array(10, 11), Array(12, 12), _
                           Array(13, 13), Array(14, 15), Array(16, 17), Array(18, 19), Array(20, 21))

    ' Find the last row in the report sheet
    lastRow = wsReport.Cells(wsReport.Rows.Count, 1).End(xlUp).Row

    ' Loop through rows from the bottom to the top
    For i = lastRow To 4 Step -1 ' Data starts from row 4

        isRowEmpty = True

        ' Check each country column pair for non-blank data
        For Each col In countryColumns
            ' Check if at least one of the two columns for the current country contains data
            If wsReport.Cells(i, col(0)).Value <> "" Or wsReport.Cells(i, col(1)).Value <> "" Then
                isRowEmpty = False
                Exit For
            End If
        Next col

        ' If the row is empty in all checked columns, delete it
        If isRowEmpty Then
            wsReport.Rows(i).Delete
        End If
    Next i
End Sub