Loop the code till the cell is empty in excel - excel

Question

I stuck with this problem:
I have this code and it works but I struggle now.
I want the loop this whole code till in Table1 the cell D1 is empty.
Sub strule()
Dim myCellRange As Range
Worksheets("Table1").Select
Code = Range("D1")
Wert = Range("E10")
Worksheets("Table2").Select
Worksheets("Table2").Range("A1").Select
lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row
Range("A" & lMaxRows).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Code
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Wert
Sheets("Table1").Select '
Rows("1:10").Select
Selection.Cut
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End Sub

Answer 1

I've had a guess at what you want... could be completely wrong though.
First of all your original code with all the selecting & activating removed:
Sub strule()
Dim WrkSht1 As Worksheet
Set WrkSht1 = Worksheets("Table1")
'Worksheets("Table1").Select
Dim Code As String
Code = WrkSht1.Range("D1")
Dim Wert As String
Wert = WrkSht1.Range("E10")
Dim WrkSht2 As Worksheet
Set WrkSht2 = Worksheets("Table2")
'Worksheets("Table2").Select
'Worksheets("Table2").Range("A1").Select
Dim lMaxRows As Long
lMaxRows = WrkSht2.Cells(Rows.Count, "A").End(xlUp).Row
WrkSht2.Cells(lMaxRows + 1, 1) = Code 'Lastrow+1 in column A.
WrkSht2.Cells(lMaxRows + 1, 2) = Wert 'Lastrow+1 in column B.
'Range("A" & lMaxRows).Select
'ActiveCell.Offset(1, 0).Select
'ActiveCell.Value = Code
'ActiveCell.Offset(0, 1).Select
'ActiveCell.Value = Wert
WrkSht1.Rows("1:10").Delete shift:=xlUp
'Sheets("Table1").Select '
'Rows("1:10").Select
'Selection.Cut
'Application.CutCopyMode = False
'Selection.Delete Shift:=xlUp
End Sub
Now what I think you want:
Sub strule1()
Dim WrkSht1 As Worksheet
Set WrkSht1 = Worksheets("Table1")
Dim WrkSht2 As Worksheet
Set WrkSht2 = Worksheets("Table2")
Dim lLastRow1 As Long
lLastRow1 = WrkSht1.Cells(Rows.Count, "A").End(xlUp).Row
Dim x As Long
Dim lLastRow2 As Long
Dim Code As String
Dim Wert As String
For x = 1 To lLastRow1 Step 10
Code = WrkSht1.Cells(x, 4) 'Loop 1 grabs from row 1, loop 2 from row 11
Wert = WrkSht1.Cells(x + 9, 5) 'Loop 1 grabs from row 10, loop 2 from row 20
lLastRow2 = WrkSht2.Cells(Rows.Count, "A").End(xlUp).Row
WrkSht2.Cells(lLastRow2 + 1, 1) = Code 'Lastrow+1 in column A.
WrkSht2.Cells(lLastRow2 + 1, 2) = Wert 'Lastrow+1 in column B.
Next x
WrkSht1.Rows("1:" & x).Delete shift:=xlUp
End Sub