Auto copy and insert a defined number of rows as defined in a cell

[Billy]

Hi
I don't know much about VBA but could probably work something out.
I need to produce carton labels from a spreadsheet using Word to mail merge
and the labels need to include 1 of 10, 2 of 10 on them. The number of
labels required is dependant on a number which is included for each row of
data in the spreadsheet. What I am doing at the moment is copying each row
and insert pasting the additional number of rows required. In the new rows I
then add 1 of 10 in the first row, 2 of 10 in the second row etc. etc. This
then enables me to perform the mailmerge.
I have around 300 label variants (300 different rows of data) which yield
around 2500 labels and I have to do this every 3 weeks. As you can imagine
it takes a crazy amount of time and requires a lot of checking.
I'd guess there must be a much easier way that even someone of my moderate
experience could execute but I need a few pointers to get me started.
Any advice greatly appreciated.

 

[Project Mangler]

Sub InsertRows()
'assumes column A contains the total number of rows required for each
'row of data
'assumes this cell can be overwritten with "1 of n"
'A3 taken as the first cell containing data
'assumes Sheet1 contains the data

'turn off screen updating for speed
Application.ScreenUpdating = False

'initialize variables
Dim rngEndcell As Range 'last occupied cell in column A
Dim rngInsrt As Range 'range of occupied cells in Column A
Dim L As Long 'number of rows to be inserted
Dim i As Long 'loop variable
Dim S As Long 'loop variable
Dim v As Long 'loop variable
Dim T As Range 'transient address of cell below which rows are
added

'get address of last occupied cell in column A
Set rngEndcell = Sheets("sheet1").Cells(Rows.Count, "A").End(xlUp)
'set the occupied range
Set rngInsrt = Range("A3", rngEndcell)
'initialise a loop variable with the number of rows
i = rngInsrt.Rows.Count

'step through the range from the bottom up
For S = i To 1 Step -1

'T holds the address of the cell below which rows are inserted
Set T = Range("A3").Offset(S - 1, 0)
'L holds the total number of rows required
L = Range("A3").Offset(S - 1, 0).Value

T = "1 of " & L
'perform the loop inserting rows and
'copying the initial row and setting the "1 of n" value
For v = 1 To L - 1
T.Offset(v, 0).EntireRow.Insert shift:=xlDown
T.EntireRow.Copy
T.Offset(v, 0).EntireRow.PasteSpecial xlPasteValuesAndNumberFormats
T.Offset(v, 0) = v + 1 & " of " & L
Next v

Next S

'get rid of crawling ants
Application.CutCopyMode = False

'select a finishing location for the cursor
Sheets("sheet1").Range("A1").Select

Application.ScreenUpdating = True

End Sub