Loop Fails To Remove Value

I am trying to remove values in column D if the value in anyone of the rows in column D is zero, here is the macro, for some reason it only removes some of the zeros, if I run it multiple times it eventuelly removes all the zeros:

Sub Removezeros()
Dim rct As Long
Dim i As Long
rct = Application.WorksheetFunction. CountA( Range("d2", Range("d65536").End(xlUp)))
For i = 2 To rct
If Cells(i, 4).Value = 0 Then
Cells(i, 4).EntireRow.Delete
Else
End If
Next i
End Sub