Hallo Benny,
ich hoffe, das klappt so wie gewünscht:
Sub losche_Leerzeilen_kopiere_Rest()
Dim Adr As String, _
i As Long, laR As Long, _
z1 As Byte, z2 As Byte, z3 As Byte, j As Byte
Application.ScreenUpdating = False
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).name = "SuS"
For j = 1 To 2
With Worksheets("0" & j)
z1 = 41
z3 = 53
For i = 41 To 6 Step -1
If WorksheetFunction.CountA(.Rows(i)) = 0 Then
z1 = z1 - 1
z3 = z3 - 1
.Rows(i).Delete
End If
Next i
z2 = z3 + 36
For i = z3 + 12 To z3 Step -1
If WorksheetFunction.CountA(.Rows(i)) = 0 Then
z2 = z2 - 1
.Rows(i).Delete
End If
Next i
End With
With Worksheets(Sheets.Count)
On Error Resume Next
laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
On Error GoTo 0
Worksheets("0" & j).Range("A4:IV" & z1).Copy _
Destination:=.Range("A" & laR + 1)
Application.CutCopyMode = False
On Error Resume Next
laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
On Error GoTo 0
Worksheets("0" & j).Range("A" & z3 & ":IV" & z2).Copy _
Destination:=.Range("A" & laR + 1)
Application.CutCopyMode = False
End With
Next j
With Worksheets(Sheets.Count)
On Error Resume Next
laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
On Error GoTo 0
If laR = 0 Then Exit Sub
.Range("A1:A" & laR).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Adr = .Cells(.Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row, _
.Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column).Address
.Range("A1:" & Adr).Sort Key1:=.Range("F1"), Order1:=xlAscending, Key2:=.Range("B1"), _
Order2:=xlAscending, Key3:=.Range("A1"), Order3:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
End With
Application.ScreenUpdating = True
End Sub
Gruß
WernerB.