Give this a whirl:
Sub Jameswright()
Dim ws As Worksheet: Set ws = Sheets("Sheet1") 'make sure this matches your sheet name
Dim bNewRow As Boolean
Dim iCredit As Integer, i As Integer
Dim sCode As String
Application.ScreenUpdating = False
For i = ws.Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
bNewRow = False
Select Case ws.Range("A" & i).Value
Case Is = "13410"
bNewRow = True
iCredit = 10
sCode = "98450"
Case Is = "13430"
bNewRow = True
iCredit = 30
sCode = "97730"
End Select
If bNewRow = True Then
ws.Range("A" & i).Offset(1).EntireRow.Insert Shift:=xlDown
ws.Range("A" & i).Offset(1).Value = sCode
ws.Range("B" & i).Offset(1).Value = 0
ws.Range("C" & i).Offset(1).Value = iCredit
ws.Range("D" & i).Resize(2, 1).FillDown
End If
Next i
Application.ScreenUpdating = True
End Sub
Bookmarks