Forum Discussion
How to duplicate rows based on cell values on that same row
Hi everyone,
This is a request that I received from my company, I've worked with excel for years but have never seen something like this.
I need to double or triple a row based on values from the same row, for example, if a row only has spend, it stays that way, if it has spend and tax, it has to be doubled, one row for spend and another for tax, if it has spend, tax and "other", it has to be tripled, one row for each item respectively.
Please see the example, I did this manually, but I need a way to make it work automatically for hundreds of lines.
Thank you.
Sub expand() Dim i As Long Dim k As Long Dim maxrow As Long Range(Cells(2, 11), Cells(2000, 19)).Clear maxrow = Cells(Rows.Count, 1).End(xlUp).Row k = 2 For i = 2 To maxrow If Cells(i, 5).Value > 0 And Cells(i, 6).Value > 0 And Cells(i, 7).Value > 0 Then Sheets("Tabelle1").Range(Cells(i, 1), Cells(i, 9)).Copy Sheets("Tabelle1").Range(Cells(k, 11), Cells(k, 19)) Range(Cells(k, 16), Cells(k, 17)).Clear Sheets("Tabelle1").Range(Cells(i, 1), Cells(i, 9)).Copy Sheets("Tabelle1").Range(Cells(k + 1, 11), Cells(k + 1, 19)) Cells(k + 1, 15).Clear Cells(k + 1, 17).Clear Sheets("Tabelle1").Range(Cells(i, 1), Cells(i, 9)).Copy Sheets("Tabelle1").Range(Cells(k + 2, 11), Cells(k + 2, 19)) Cells(k + 2, 15).Clear Cells(k + 2, 16).Clear k = k + 3 Else If Cells(i, 5).Value > 0 And Cells(i, 6).Value > 0 Then Sheets("Tabelle1").Range(Cells(i, 1), Cells(i, 9)).Copy Sheets("Tabelle1").Range(Cells(k, 11), Cells(k, 19)) Cells(k, 16).Clear Sheets("Tabelle1").Range(Cells(i, 1), Cells(i, 9)).Copy Sheets("Tabelle1").Range(Cells(k + 1, 11), Cells(k + 1, 19)) Cells(k + 1, 15).Clear k = k + 2 Else Sheets("Tabelle1").Range(Cells(i, 1), Cells(i, 9)).Copy Sheets("Tabelle1").Range(Cells(k, 11), Cells(k, 19)) k = k + 1 End If End If Next i End SubYou can try these lines of code. In the attached file you can click the button in cell U4 to run the macro.
2 Replies
Sub expand() Dim i As Long Dim k As Long Dim maxrow As Long Range(Cells(2, 11), Cells(2000, 19)).Clear maxrow = Cells(Rows.Count, 1).End(xlUp).Row k = 2 For i = 2 To maxrow If Cells(i, 5).Value > 0 And Cells(i, 6).Value > 0 And Cells(i, 7).Value > 0 Then Sheets("Tabelle1").Range(Cells(i, 1), Cells(i, 9)).Copy Sheets("Tabelle1").Range(Cells(k, 11), Cells(k, 19)) Range(Cells(k, 16), Cells(k, 17)).Clear Sheets("Tabelle1").Range(Cells(i, 1), Cells(i, 9)).Copy Sheets("Tabelle1").Range(Cells(k + 1, 11), Cells(k + 1, 19)) Cells(k + 1, 15).Clear Cells(k + 1, 17).Clear Sheets("Tabelle1").Range(Cells(i, 1), Cells(i, 9)).Copy Sheets("Tabelle1").Range(Cells(k + 2, 11), Cells(k + 2, 19)) Cells(k + 2, 15).Clear Cells(k + 2, 16).Clear k = k + 3 Else If Cells(i, 5).Value > 0 And Cells(i, 6).Value > 0 Then Sheets("Tabelle1").Range(Cells(i, 1), Cells(i, 9)).Copy Sheets("Tabelle1").Range(Cells(k, 11), Cells(k, 19)) Cells(k, 16).Clear Sheets("Tabelle1").Range(Cells(i, 1), Cells(i, 9)).Copy Sheets("Tabelle1").Range(Cells(k + 1, 11), Cells(k + 1, 19)) Cells(k + 1, 15).Clear k = k + 2 Else Sheets("Tabelle1").Range(Cells(i, 1), Cells(i, 9)).Copy Sheets("Tabelle1").Range(Cells(k, 11), Cells(k, 19)) k = k + 1 End If End If Next i End SubYou can try these lines of code. In the attached file you can click the button in cell U4 to run the macro.
