Macro getting caught in loop

Hello...

I have the following code pasted into Module 1 in my PERSONAL.xls workbook:

Sub Delete_Empty_Rows()
' DELETE BLANK ROWS FROM CURRENT SPREADSHEET

    Dim LastRow As Long
    Dim CurrentRow As Long
    
' FIND THE LAST ROW POPULATED WITH DATA IN COLUMN A
    With ActiveSheet
        LastRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
    End With

' LOOP FROM ROW 1 TO LAST ROW OF DATA
    For CurrentRow = 1 To LastRow
    
' USE DO WHILE IN CASE THERE ARE TWO CONSECUTIVE BLANK ROWS
    Do While IsEmpty(Cells(CurrentRow, 1))
       Rows(CurrentRow & ":" & CurrentRow).Select
       Selection.Delete Shift:=xlUp
    Loop
Next CurrentRow

End Sub

When the macro is run...it deletes blank rows on the active worksheet.
Everything works fine until the macro reaches the LAST ROW in Column A.

At that point...the macro should stop...but it seems to continue running.

What am I doing wrong??

(A sample file has been attached)