Delete Multiple Rows Based on Criteria in 1 Column

Kind of crude (works on sample workbook):
It goes down column B searching for empty cells. When one is found, it checks the adjacent A, if it has data, the entire block, plus the next row is hidden.
When all empty B's have been processed, it starts at the bottom and deletes hidden rows.

Sub Compact()
    Application.ScreenUpdating = False
    Dim result      As Variant, _
        lastrow     As Long, _
        BRng        As Range, _
        Testcell    As Range, _
        FirstFound  As String
    
    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    Set BRng = Range("b3:B" & lastrow)
    
    With BRng
        Set Testcell = .Find("")
        If Not Testcell Is Nothing Then
            FirstFound = Testcell.Address(0, 0)
            Do
                If Testcell.Offset(0, -1) <> "" Then
                    result = .Offset(-1, 0).Resize(, 5).Value
                    Testcell.CurrentRegion.Resize(Testcell.CurrentRegion.Rows.Count + 1).EntireRow.Hidden = True
                End If
                
                Set Testcell = .FindNext(Testcell)
            Loop While Not Testcell Is Nothing And Testcell.Address(0, 0) <> FirstFound
        End If
    End With 'BRng
    
    For result = lastrow To 1 Step -1
        If Range("A" & result).EntireRow.Hidden = True Then
            Range("A" & result).EntireRow.Delete
        End If
    Next result
    Application.ScreenUpdating = True
End Sub

It works on the sample with those many blank rows. Your actual must be significantly different than the sample...

Try deleting the "+1" which expands the selection to the next row below the blank Bcell:

Testcell.CurrentRegion.Resize(Testcell.CurrentRegion.Rows.Count + 1).EntireRow.Hidden = True

Or, upload a more accurate sample file.