Sub regis()
Dim cell As Range
Set cell = Range("A2")
Do While cell.Value <> ""
If WorksheetFunction.CountIf(Range("A:A"), "=" & cell.Value) < cell.Offset(0, 3).Value Then
Range(Cells(cell.Row + 1, 1).Address & ":" & Cells(cell.Row + 1, 4).Address) _
.Insert Shift:=xlDown
For i = 1 To 4
Cells(cell.Row + 1, i) = Cells(cell.Row, i)
Next i
End If
Set cell = cell.Offset(1, 0)
Loop
End Sub