VBA code to insert a variable # of rows between each existing row matching certain criteria. Help please!

[ktsmith21]

Hello, I need some help on VBA, please. I've inlcuded an short example below of what I am trying to achieve.

I am trying to figure out the VBA to insert a variable number of rows (based on the value in Settings!C13) between existing rows on the worksheet 'UNIT_PRICE_COMP'. Some rows are category headers, and this is reflected by the value in column B being less than 1000.

Essentially, I need VBA for the following: For each cell in B < 1000, Insert X number of rows, where X = Settings!C13.

Finally, in column G, I need to add the name of the Partner, from the settings page. I need to include the value from Settings!C7 on the first row of any added rows, Settings!C9 on the next, and Settings!C11 on row 3 (if there is a third inserted row).

In the example below, the 'Settings' tab values are as follows:
Settings!C7 = PARTNER 1
Settings!C9 = PARTNER 2
Settings!C11 = PARTNER 3
Settings!C13 = 2

Any help is greatly appreciated!

	Column B	Column C	Column D	Column E	Column F	Column G
Row 3	ITEM NO.	CHAPTER	ITEM DESCRIPTION	UNIT	TYPE	PARTNER
Row 4
Row 5	10	1.01 - ROADW	ROADWAY REMOVALS		D
Row 6	1000	1.01 - ROADW	PREPARING ROW	AC	D
inserted by VBA						PARTNER 1
inserted by VBA						PARTNER 2
Row 7	1010	1.01 - ROADW	REMOVING CONC (PAV)	SY	D
inserted by VBA						PARTNER 1
inserted by VBA						PARTNER 2
Row 8	1020	1.01 - ROADW	REMOVING CONC (RIPRAP)	SY	D
inserted by VBA						PARTNER 1
inserted by VBA						PARTNER 2

 

[offthelip]

Your description is asking for extra rows when B < 1000, however your example appearrs to be asking for extra rows when B >= 1000. I have implemented the latter, it is easily changed if that is wrong.
try this code, I have used variant arrays which makes it very fast

Sub test()
With Worksheets("settings")
 partners = Range(.Cells(7, 3), .Cells(11, 3))
 C13 = Range(.Cells(13, 3), .Cells(13, 3))
End With
Dim outarr() As Variant
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
inarr = Range(Cells(1, 1), Cells(lastrow, 7))
ReDim outarr(1 To lastrow * 4, 1 To 7)
'copy headers
  For j = 1 To 6
    outarr(1, j) = inarr(1, j)
  Next j
indi = 2
For i = 2 To lastrow
  ' copy a row
  For j = 1 To 6
    outarr(indi, j) = inarr(i, j)
  Next j
  indi = indi + 1
  ' check if extra rows needed
  If inarr(i, 2) >= 1000 Then
     For k = 0 To C13 - 1
      outarr(indi, 7) = partners(1 + k * 2, 1)
      indi = indi + 1
     Next k
  End If
Next i
Range(Cells(1, 1), Cells(indi, 7)) = outarr

End Sub

.