Adding rows with a macro: Is this possible

[racekarr]

I have a spread sheet exported from Quick Books. The data is from purchase orders and inventory. Unfortunately, Quick Books exports the data of "quantity" as a number in the line item. To make price tags and inventory stickers, I need to take the "quantity" field in Excell and convert it to an equal number of rows. The reason I want to do this with a macro or other automated means is there can be 100's of rows of data with item quantities varying from 1 to more than 100. It gets very tedious copying and pasting in this manner. Here is what I would like to accomplish:

Book1
	A	B	C	D
1		BEFORE
2
3	ITEM	DESCRIPTION	QTY	PRICE
4	96-456	BOLTA	5	3.59
5	96-435	BOLTB	6	4.07
6	96-567	BOLTC	7	5.95
7
8
9		AFTER
10
11	ITEM	DESCRIPTION	QTY	PRICE
12	96-456	BOLTA	1	3.59
13	96-456	BOLTA	1	3.59
14	96-456	BOLTA	1	3.59
15	96-456	BOLTA	1	3.59
16	96-456	BOLTA	1	3.59
17	96-435	BOLTB	1	4.07
18	96-435	BOLTB	1	4.07
19	96-435	BOLTB	1	4.07
20	96-435	BOLTB	1	4.07
21	96-435	BOLTB	1	4.07
22	96-435	BOLTB	1	4.07
23	96-567	BOLTC	1	5.95
24	96-567	BOLTC	1	5.95
25	96-567	BOLTC	1	5.95
26	96-567	BOLTC	1	5.95
27	96-567	BOLTC	1	5.95
28	96-567	BOLTC	1	5.95
29	96-567	BOLTC	1	5.95
Sheet1

Is it possible to do this with a macro by reading the quantity field and then automatically copying and pasting the correct numbers of rows, then change the quantity field to 1?

Thanks for any input.

 

[KenWright]

How about

Sub ExtendRows()

Application.ScreenUpdating = False
Dim numRows As Integer
Dim r As Long
Dim rws As Long
Dim cls As Long
Dim Rng As Range
Dim LastRw As Long


LastRw = Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = Range(Cells(1, "C"), Cells(LastRw, "C"))

  On Error Resume Next
  For r = Rng.Rows.Count To 2 Step -1
     If Rng.Rows(r).Offset(0, -2) <> "" Then
        numRows = Rng.Rows(r).Value - 1
        Rng.Rows(r + 1).Resize(numRows).EntireRow.Insert
        For rws = 1 To numRows
            For cls = 1 To 4
                Cells(r, cls).Offset(rws, 0).Value = Cells(r, cls).Value
                Cells(r, 3).Offset(rws, 0).Value = 1
            Next
        Next
        Cells(r, 3).Value = 1
     Else: Exit For
     End If
  Next r

Application.ScreenUpdating = True

End Sub

Ken.......

 

[erik.van.geit]

Hi, racekarr,
Welcome to the Board!

this is working for me

Option Explicit

Sub adding_rows()
Dim rrr As Long
Dim fr As Long
Dim nr As Integer
Dim fc As Integer
Dim lc As Integer
Dim rc As Integer
fr = 2 'first row
fc = 1 'first column
lc = 4 'last column
rc = 3 'reference column

Application.ScreenUpdating = False
For rrr = Cells(65536, 1).End(xlUp).Row To fr Step -1
nr = Cells(rrr, rc) - 1
Rows(rrr + 1 & ":" & rrr + nr).Insert
Range(Cells(rrr, fc), Cells(rrr, lc)).Copy Range(Cells(rrr, fc), Cells(rrr + nr, lc))
Next rrr
Range(Cells(fr, rc), Cells(65536, rc).End(xlUp)) = 1
Application.ScreenUpdating = True
End Sub

is it for you ?
Step through the code with F8: so you will learn how things work ...

regards,
Erik

 

[Legacy 12630]

To make price tags and inventory stickers, I need to take the "quantity" field in Excell and convert it to an equal number of rows.

How are you printing your tags/stickers?

Perhaps it would be better to have a macro that prints the necessary number of tags/stickers per item without having to make any changes to your worksheet.

 

[racekarr]

THANK YOU!!!!! Works like a champ KenWright. You are the man!
Eric, I couldn't get your code to work. I am sure it is because I don't have the knowledge to adapt it to my application. Thanks for the effort both of you. I now know where I can turn with my questions.

Thanks again.

 

[racekarr]

Ponsonby,

I am using Microsoft Word to print the stickers through the mail merge feature using the Excel Spreadsheet as the data source.

 

[erik.van.geit]

I agree with Ponsonby: This is perhaps a good example of cases were an analysis of the situation avoids some "useless" work.
Sometimes we try to do what people ask, without looking to what they try to achieve. just like inventing the wheel.
Racekarr, perhaps Ponsonby showed us where the wheel was

kind regards,
succes with your application
Erik

 

[KenWright]

LOL - With you 100% there erik

Ken.......