Duplicate Line by cell qty

[reldridge]

I have a spreadsheet as layed out below: I need to duplicate any lines that the qty is above 4000, and create a new line for the remainder.

So the one with a qty of 6000 would change to two lines:
AIRPORT STATION 4000 RACK AIRPORT STATION 8
AIRPORT STATION 2000 RACK AIRPORT STATION 8

Raw data:

IN_CARE_OFQUANTITYLOCATIONCARD
AIRPORT STATION 200 RACK AIRPORT STATION 1
AIRPORT STATION 4000 RACK AIRPORT STATION 4
AIRPORT STATION 8000 RACK AIRPORT STATION 005/10
AIRPORT STATION 200 RACK AIRPORT STATION 7
AIRPORT STATION 6000 RACK AIRPORT STATION 8
AIRPORT STATION 800 RACK AIRPORT STATION 9
AIRPORT STATION 1000 RACK AIRPORT STATION 11

 

[reldridge]

Can i alter this code so that the insert of colume "B" is then minused by 4000?

Sub testme()
Dim wks As Worksheet
Dim iRow As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim HowManyMore As Long
Set wks = Worksheets("Sheet1")
With wks
FirstRow = 2
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For iRow = LastRow To FirstRow Step -1
HowManyMore = .Cells(iRow, "G").Value - 1
If HowManyMore > 0 Then
.Rows(iRow + 1).Resize(HowManyMore).Insert
.Cells(iRow + 1, "A").Resize(HowManyMore, 1).Value _
= .Cells(iRow, "A").Value
.Cells(iRow + 1, "B").Resize(HowManyMore, 1).Value _
= .Cells(iRow, "B").Value
.Cells(iRow + 1, "C").Resize(HowManyMore, 1).Value _
= .Cells(iRow, "C").Value
.Cells(iRow + 1, "D").Resize(HowManyMore, 1).Value _
= .Cells(iRow, "D").Value
.Cells(iRow + 1, "E").Resize(HowManyMore, 1).Value _
= .Cells(iRow, "E").Value
.Cells(iRow + 1, "H").Resize(HowManyMore, 1).Value _
= .Cells(iRow, "H").Value
End If
Next iRow
End With
End Sub