Revisar consecutivo de Folios e Insertar filas

Buenas tardes, sucede que tengo esta macro que encontré buscando en google, la cual, me revisa de X columna, el consecutivo de folio y me inserta filas con los códigos faltantes.

Me encuentro trabajando con filtros, por lo que primero, reviso una sucursal. Entonces, mi problema viene cuando el rango en la fila aumenta por los 1770, entonces al querer ejecutar la macro, me salta el error de recursos insuficientes, cosa que no es real.

Entonces, quisiera ver la manera de modificar el código en cuestión, para que solo revise un rango. Ya que al final de mi ultimo número, me sigue agregando folios de manera infinita.

Este es el código que estoy usando:

Sub Macro_Consecutivo()

Dim Nro_Fila As Double

Dim Valor_Celda As Double

Dim Comienzo_Fila As Double

Nro_Fila = InputBox("Ingrese el Nro de Fila desde donde se Comenzará a Chequear el Consecutivo", "No de Fila Inicial")

Comienzo_Fila = Nro_Fila

Valor_Celda = Range("D" & Nro_Fila).Value

Do While Val(Range("D" & Nro_Fila).Value) > 0

If Nro_Fila > Comienzo_Fila Then

If Val(Range("D" & Nro_Fila).Value) > Valor_Celda Then

Rows(Nro_Fila & ":" & Nro_Fila).Select

Selection.Insert Shift:=xlDown

Range("D" & Nro_Fila).Value = Valor_Celda

End If

End If

Nro_Fila = Nro_Fila + 1

Valor_Celda = Valor_Celda + 1

Loop

End Sub