Excel VBA how can I find where two blank rows appear and delete one of those rows?

Question

My worksheet contains blank rows which I want to keep.

However it also contains groups of two blank rows and I want to keep one of them but delete/remove the other one.

END RESULT: sheet contains only single blank rows.

First attachment shows before (highlighted where two blank rows) and second attachment shows desired final result (worksheet only contains single blank rows).

What is the VBA code to achieve this please?

Something like:

1. select all
2. identify where two blank rows are and delete one of those rows

Thanks in advance!

---

In an attempt to improve the question and show my efforts with my own VBA code.... this is what I had got starting with a variable counter of 0 and when it gets to 2 it would delete a row, it sort of works as in it finds and deletes the desired row but it appears to run an infinite loop :(

Sub EmptyRows()

Dim x As Integer
Dim row As Integer


  NumRows = ActiveSheet.UsedRange.Rows.Count
  ' Select cell A2.
  Range("A2").Select
  row = 0
  ' Establish "For" loop to loop "numrows" number of times.
  For x = 1 To NumRows
  
    
     If Application.CountA(ActiveCell.EntireRow) = 0 Then
        row = row + 1
     End If
     ActiveCell.Offset(1, 0).Select
     If Application.CountA(ActiveCell.EntireRow) = 0 Then
        row = row + 1
     End If
     
     If row >= 2 Then
        MsgBox "2 Rows!"
        ActiveCell.EntireRow.Delete
        
     End If
     
     ' Selects cell down 1 row from active cell.
     ActiveCell.Offset(1, 0).Select
     row = 0
  Next

 End Sub

Answer 1

Try the next code, please. It will check if really whole analyzed rows are empty:

Sub deleteSecondBlankRow()
  Dim sh As Worksheet, arr, rngDel As Range, lastR As Long, i As Long
  
  Set sh = ActiveSheet
  lastR = sh.Range("A" & sh.rows.Count).End(xlUp).row
  arr = sh.Range("A2:A" & lastR).value
  For i = 1 To UBound(arr)
        If arr(i, 1) = "" Then
            If WorksheetFunction.CountA(rows(i + 1)) = 0 Then
                If arr(i + 1, 1) = "" Then
                    If WorksheetFunction.CountA(rows(i + 2)) = 0 Then
                        If rngDel Is Nothing Then
                            Set rngDel = sh.Range("A" & i + 2)
                        Else
                            Set rngDel = Union(rngDel, sh.Range("A" & i + 2))
                        End If
                    End If
                End If
            End If
        End If
  Next i
  If Not rngDel Is Nothing Then rngDel.EntireRow.Select
End Sub

The code only selects the rows to be deleted. If you check it and what selected is convenient, you should only replace Select with Delete on the last code line...