How to duplicate rows based on cell values on that same row

leocsmith1640 

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 Sub

You can try these lines of code. In the attached file you can click the button in cell U4 to run the macro.