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

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:
select all
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...