Sub Abrechnungsammeln()
Dim WS As Worksheet
Dim WSz As Worksheet
Dim Zeile As Long
Dim i As Long
Dim n As Long
On Error GoTo ENDE
Application.ScreenUpdating = False
Set WSz = Worksheets("SAP")
n = 3
WSz.Range(n & ":" & WSz.Rows.Count).Clear
For Each WS In ThisWorkbook.Worksheets
With WS
Select Case .Name
Case "SAP"
Case Else
If Not IsEmpty(.UsedRange) Then
For Zeile = 120 To .Cells.Find("*", , , , xlByRows, xlPrevious).Row
If .Cells(Zeile, 5) > 0 Or .Cells(Zeile, 6) > 0 Then
.Rows(Zeile).Copy
WSz.Cells(n, 1).PasteSpecial (xlPasteValuesAndNumberFormats)
n = n + 1
End If
Next Zeile
End If
End Select
End With
Next
Application.CutCopyMode = False
ENDE:
Application.ScreenUpdating = True
If Err Then MsgBox Err.Description, , "Fehler: " & Err
End Sub