Excel - ayuda con ciclo infinito

Range("g1").Select

Do While ActiveCell <> ""

Do While ActiveCell <> ""

ActiveCell.Offset(1, 0).Activate

Loop

Do While ActiveCell = ""

ActiveCell.Select

Selection.Delete xlUp

Loop

Loop

Option Explicit

'//By JuanC - Ago. 2017

Sub borrar_celdas_vacias()

Dim rng As Range, c As Range

Dim ws As Worksheet, aws As Worksheet

Dim v As Variant, i&, n&, sCol$

On Error Resume Next

sCol = "G"

With Application

     .DisplayAlerts = False

     .ScreenUpdating = False

     .EnableEvents = False

      .Calculation = xlCalculationManual

End With

Set aws = ActiveSheet

Set rng = aws.Range(sCol & "1", Range(sCol & Cells.Rows.Count).End(xlUp))

v = rng.Value

Set ws = Worksheets.Add

n = UBound(v)

For i = 1 To n

    If v(i, 1) = "" Then ws.Range(sCol & "1").Offset(i - 1).Value = 1

Next

Set rng = Nothing

Set rng = ws.Range(sCol & ":" & sCol).SpecialCells(xlCellTypeConstants)

If Not rng Is Nothing Then rng.Select

aws.Select 0

ws.Delete

If Not rng Is Nothing Then Selection.Delete xlShiftUp

aws.Range("A1").Activate

With Application

    .DisplayAlerts = True

    .ScreenUpdating = True

    .EnableEvents = True

    .Calculation = xlCalculationAutomatic

End With

End Sub