Seperate line per quantity ordered

[ccameronn]

Hi all,

First time posting on here so please let me know if you need any additional info from what I provide.

In short, I am trying to to acheive the following:


Customer ABC, Address 1, Address 2, Address 3, Town, Postcode, Product Code, Description, Qty = 3


The excel file needs to be transformed into:


Customer ABC, Address 1, Address 2, Address 3, Town, Postcode, Product Code, Description, Qty = 1

Customer ABC, Address 1, Address 2, Address 3, Town, Postcode, Product Code, Description, Qty = 1

Customer ABC, Address 1, Address 2, Address 3, Town, Postcode, Product Code, Description, Qty = 1


Here are screen shots of how the file is currently presented:

The highlighted columns are those that need to be payed attention to, for example in Z7 there has been 2 of the same product ordered. This needs to be ammended to 2 lines with the quantity being '1' for each. The rest of the data in the line should be same. Below is an example of how I would like the result to be:

As you can see the line has in effect been copy and pasted, however the quantity has changed to 1 for each line. Just for clarification, this could be the case for any one of the cells within column 'Z', it all depends on whether more than one of the same product has been ordered.

Hopefully this is well undertsood and you guys can help me out! I really appreciate you having a look.

Many thanks

 

[Crystalyzer]

I think this will do what you want. Please test on a copy of your workbook.

Sub RepeatRows()
   
    Dim i  As Long
    Dim j As Long
    Dim k As Long
    Dim q as Long
   
    i = 2
    k = Cells(Rows.Count, 26).End(xlUp).Row
   
    While i <= k
        q = Cells(i, 26).Value
        If q > 1 Then
                Cells(i, 26).EntireRow.Copy
                Range(Cells(i, 26), Cells(i + q - 2, 26)).EntireRow.Insert Shift:=xlDown
                For j = 0 To q - 1
                    Cells(i + j, 26).Value = 1
                Next j
                Application.CutCopyMode = False
            'Next j
        End If
        i = i + 1
        k = k + q - 1
    Wend
End Sub

 

[ccameronn]

I think this will do what you want. Please test on a copy of your workbook.

Sub RepeatRows()
  
    Dim i  As Long
    Dim j As Long
    Dim k As Long
    Dim q as Long
  
    i = 2
    k = Cells(Rows.Count, 26).End(xlUp).Row
  
    While i <= k
        q = Cells(i, 26).Value
        If q > 1 Then
                Cells(i, 26).EntireRow.Copy
                Range(Cells(i, 26), Cells(i + q - 2, 26)).EntireRow.Insert Shift:=xlDown
                For j = 0 To q - 1
                    Cells(i + j, 26).Value = 1
                Next j
                Application.CutCopyMode = False
            'Next j
        End If
        i = i + 1
        k = k + q - 1
    Wend
End Sub

Hi there,

That is almost perfect, thank you very much for taking the time to look into this.

Apologies I should have mentioned this my original post, but sometimes we may have in excess of 50 rows on these spreadhsheets. Meaning that when I run this code, the first maybe 12 rows work great but anything past that isn't affected. Hopefully it is a simple update to the code you have already given me to solve this!

Many thanks,

Cam

 

[Crystalyzer]

I anticipated that and the line of code below is supposed to increment so that when rows are inserted it accounts for the increase in the number of rows to process.

k = k + q - 1

I have tested this with up to 100 rows and it works.

 

[Crystalyzer]

If you are still having trouble, please post your worksheet data using XL2BB tool (see signature for link to instructions)

 

[ccameronn]

If you are still having trouble, please post your worksheet data using XL2BB tool (see signature for link to instructions)

Hi again,

Thank you for the link, below is the mini sheet:

15 july 2021 15h52.csv
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG
1	Customer code	Customer reference	Name receiver	(Cell) phone number	Third line address	Address	Yes	City	Country	Address number	Add on address	EAN Number receiving address	Order date	Shipment date	Delivery terms	Internal logistical information field 1	Internal logistical information field 2	External logistical information field 1	External logistical information field 2	Reference origin order	Carrier	Line number	EAN Number of packsize	Item number	Berekend bedrag	Quantity in pieces	Item number of customer	Description of customer	Specifications of customer	Email address	Batch number	Seperate order	Dealer
2
3	236	O3100385	CustName1			SecondAddLine1	PTSCD1	City1	GB				130721	150721	FR					Ref1	13000	1	8.72E+12	3020RF0003		2				cust@example.co.uk			1
4	236	O3100402	CustName2			SecondAddLine2	PTSCD2	City2	GB				150721	150721	DAP					Ref2	13000	2	4.06E+12	4.06E+12		1				cust@example.co.uk			2
5	236	O3100402	CustName3			SecondAddLine3	PTSCD3	City3	GB				150721	150721	DAP					Ref3	13000	1	8.72E+12	2010RM0013		1				cust@example.co.uk			2
6	236	O3100405	CustName4			SecondAddLine4	PTSCD4	City4	GB				150721	150721	FR					Ref4	13000	1	4.06E+12	4.06E+12		1				cust@example.co.uk			1
7	236	O3100405	CustName5			SecondAddLine5	PTSCD5	City5	GB				150721	150721	FR					Ref5	13000	2	4.06E+12	4.06E+12		1				cust@example.co.uk			1
8	236	O3100406	CustName6			SecondAddLine6	PTSCD6	City6	GB				150721	150721	DAP					Ref6	200359	1	8.72E+12	3010RF0012		1				cust@example.co.uk			2
9	236	O3100408	CustName7			SecondAddLine7	PTSCD7	City7	GB				150721	150721	DAP					Ref7	200359	2	4.06E+12	4.06E+12		1				cust@example.co.uk			2
10	236	O3100408	CustName8			SecondAddLine8	PTSCD8	City8	GB				150721	150721	DAP					Ref8	200359	1	4.06E+12	4.06E+12		1				cust@example.co.uk			2
11	236	O3100409	CustName9		FirstAddLine1	SecondAddLine9	PTSCD9	City9	GB				150721	150721	DAP					Ref9	200359	1	8.72E+12	2010RM0012		1				cust@example.co.uk			2
12	236	O3100410	CustName10			SecondAddLine10	PTSCD10	City10	GB				150721	150721	FR					Ref10	13000	1	8.72E+12	2010RM0011		1				cust@example.co.uk			2
13	236	O3100416	CustName11			SecondAddLine11	PTSCD11	City11	GB				150721	150721	FR					Ref11	13000	2	8.72E+12	2010RM0010		2				cust@example.co.uk			2
14	236	O3100416	CustName12			SecondAddLine12	PTSCD12	City12	GB				150721	150721	FR					Ref12	13000	3	8.72E+12	2010RM0012		2				cust@example.co.uk			2
15	236	O3100416	CustName13			SecondAddLine13	PTSCD13	City13	GB				150721	150721	FR					Ref13	13000	4	4.06E+12	4.06E+12		1				cust@example.co.uk			2
16	236	O3100416	CustName14			SecondAddLine14	PTSCD14	City14	GB				150721	150721	FR					Ref14	13000	1	4.06E+12	4.06E+12		1				cust@example.co.uk			2
17	236	O3100416	CustName15			SecondAddLine15	PTSCD15	City15	GB				150721	150721	FR					Ref15	13000	5	4.06E+12	4.06E+12		2				cust@example.co.uk			2
15 july 2021 15h52

This is the spreadsheet before running the macro, if you test it you will see that the last row (17) still shows that the quantity = 2.

The issue could be to do with the format of the spreadsheet that I have provided, however I am unable to spot the discrepancy.

Many thanks

 

[Crystalyzer]

ok, I didn't account for a blank row in row 2 in my code. I have updated it and it is below. Running this code on your source data above works for every row and does not skip any or stop processing.

Sub RepeatRows()
    Dim i  As Long
    Dim j As Long
    Dim k As Long
       
    i = 2
    k = Cells(Rows.Count, 26).End(xlUp).Row
    
        While i <= k
            q = Cells(i, 26).Value
            If q > 1 Then
                    Cells(i, 26).EntireRow.Copy
                    Range(Cells(i, 26), Cells(i + q - 2, 26)).EntireRow.Insert Shift:=xlDown
                    For j = 0 To q - 1
                        Cells(i + j, 26).Value = 1
                    Next j
                    Application.CutCopyMode = False
            End If
            i = i + 1
            If q <> 0 Then k = k + q - 1
        Wend
End Sub

 

[ccameronn]

ok, I didn't account for a blank row in row 2 in my code. I have updated it and it is below. Running this code on your source data above works for every row and does not skip any or stop processing.

Sub RepeatRows()
    Dim i  As Long
    Dim j As Long
    Dim k As Long
      
    i = 2
    k = Cells(Rows.Count, 26).End(xlUp).Row
   
        While i <= k
            q = Cells(i, 26).Value
            If q > 1 Then
                    Cells(i, 26).EntireRow.Copy
                    Range(Cells(i, 26), Cells(i + q - 2, 26)).EntireRow.Insert Shift:=xlDown
                    For j = 0 To q - 1
                        Cells(i + j, 26).Value = 1
                    Next j
                    Application.CutCopyMode = False
            End If
            i = i + 1
            If q <> 0 Then k = k + q - 1
        Wend
End Sub

Absolutely spot on. Thank you again for your help, it works perfectly.

Cam