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!

---

3	0	Elk (23)|||||Fairgrounds (1)	English	#########	#########			6	x
4	0	Elk (1)|Rosemont (4)|Main (15)|Fairgrounds| (3)	English	#########	#########			6	x
5		Elk (23)|Fairgrounds (1)					7	x
6		Elk (1)||||Rosemont (4)|Main (15)|Fairgrounds (3)			3	x
7		Elk (23)|Fairgrounds (1)					2	x

<colgroup><col span="11"></colgroup><tbody>
</tbody>

 

[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