Copy row based on criteria paste row then delete original row and use next row in line

[Deinoc]

Hello all:
So I have been using this from mrshl9898 that copies a row nth times based on a cell value (A1 to K1, J1 times). It works but I want to use it to loop until the worksheet is empty. I will be processing thousands of rows, so thousand clicks will not work and also "Cells(rownum, 1)" replaces the first cell on sheet2.

Private Sub CommandButton1_Click()


Dim rownum As Long
Dim copycount As Long
Dim x As Long




copycount = Sheets("Sheet1").Range("J1").Value
Sheets("Sheet1").Range("A1:K1").Copy




x = 0
rownum = 1




Do Until x = copycount




Sheets("Sheet2").Cells(rownum, 1).PasteSpecial xlPasteAll
x = x + 1
rownum = rownum + 1


Loop




End Sub

This is the data example that will be processed thanks!

---

[TABLE="width: 748"]
<colgroup><col span="11"></colgroup><tbody>[TR]
[TD="align: right"]3[/TD]
[TD="align: right"]0[/TD]
[TD="colspan: 2"]Elk (23)|||||Fairgrounds (1)[/TD]
[TD]English[/TD]
[TD="align: center"]#########[/TD]
[TD="align: center"]#########[/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]6[/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD="align: right"]4[/TD]
[TD="align: right"]0[/TD]
[TD="colspan: 2"]Elk (1)|Rosemont (4)|Main (15)|Fairgrounds| (3)[/TD]
[TD]English[/TD]
[TD="align: center"]#########[/TD]
[TD="align: center"]#########[/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]6[/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD="align: right"]5[/TD]
[TD][/TD]
[TD="colspan: 3"]Elk (23)|Fairgrounds (1)[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]7[/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD="align: right"]6[/TD]
[TD][/TD]
[TD="colspan: 5"]Elk (1)||||Rosemont (4)|Main (15)|Fairgrounds (3)[/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]3[/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD="align: right"]7[/TD]
[TD][/TD]
[TD="colspan: 3"]Elk (23)|Fairgrounds (1)[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]2[/TD]
[TD]x[/TD]
[/TR]
</tbody>[/TABLE]

 

[My Aswer Is This]

Not sure what this means:
also "Cells(rownum, 1)" replaces the first cell on sheet2.
<strike></strike>

 

[Fluff]

@Deinoc
Have you looked at my suggestion here?
https://www.mrexcel.com/forum/excel...-macros-mid-find-text-column.html#post4957028

 

[My Aswer Is This]

Try this:

Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Lastrow = Sheets("Sheet1").Cells(Rows.Count, "J").End(xlUp).Row
Dim Lastrowa As Long
Lastrowa = Sheets("Sheet2").Cells(Rows.Count, "J").End(xlUp).Row + 1
    For i = 1 To Lastrow
    ans = Cells(i, "J").Value
    Sheets("Sheet1").Range(Cells(i, "A"), Cells(i, "K")).Copy
    Sheets(2).Range("A" & Lastrowa).Resize(ans).PasteSpecial
    Lastrowa = Sheets("Sheet2").Cells(Rows.Count, "J").End(xlUp).Row + 1
Next
Application.ScreenUpdating = False
End Sub

 

[My Aswer Is This]

If you do not need to copy formatting you can try this it would be faster.
It only moves values to Sheet 2

Private Sub CommandButton3_Click()
'no copy
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Lastrow = Sheets("Sheet1").Cells(Rows.Count, "J").End(xlUp).Row
Dim Lastrowa As Long
Lastrowa = Sheets("Sheet2").Cells(Rows.Count, "J").End(xlUp).Row + 1
    For i = 1 To Lastrow
    ans = Cells(i, "J").Value
    Sheets(2).Range("A" & Lastrowa & ":K" & Lastrowa).Resize(ans).Value = Sheets("Sheet1").Range(Cells(i, "A"), Cells(i, "K")).Value
    Lastrowa = Sheets("Sheet2").Cells(Rows.Count, "J").End(xlUp).Row + 1
Next
Application.ScreenUpdating = False