Add X number of rows based on value of cell

Hi

I want to insert C rows of each ID from column A. The number of rows I want inserted differ for each ID.

Sample workbook is attached.

Cheers,

Sub addCrows()

strLastCrow = CStr(Range("C" & CStr(Application.Rows.Count)).End(xlUp).Row)

'inserts the desired number of rows
For c = strLastCrow To 2 Step -1
    r = Range("C" & c).Value
    rs = c + r
    Range("C" & c & ":" & "C" & rs).Offset(1).EntireRow.Insert
Next

'fills in the id number
strLastArow = CStr(Range("A" & CStr(Application.Rows.Count)).End(xlUp).Row)

For c = 2 To strLastArow Step 1
    If Range("A" & c) = "" Then Range("A" & c).FillDown
Next


End Sub

It adds one too many rows, but I can just dial the number down one.

Thanks a bunch I'll see if it works on the larger data set.

On your sample, you have one more rows than the numbers on the column C.