Sub kopieren_loeschen_neu7()
Dim anfang, ende, zeile, lzeile, szeile As Integer
'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False
'letzte Zeile im aktiven Arbeitsblatt "Reichweite" ermitteln
lzeile = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
'Anfang des zu kopierenden Bereichs suchen: zwei Zeilen untereinander mit ---
For zeile = 6 To lzeile
If Left(ActiveSheet.Cells(zeile, 1).Value, 1) = "-" And Left(ActiveSheet.Cells(zeile - 1, 1).Value, 1) = "-" Then
anfang = zeile + 1
Exit For
End If
Next zeile
For zeile = 6 To lzeile
'Gesamtsumme
If Left(ActiveSheet.Cells(zeile, 3).Value, 11) = "Gesamtsumme" Then
ende = zeile
Exit For
End If
Next zeile
For zeile = ende To lzeile
'Trennlinie nach Gesamtsumme suchen
If Left(ActiveSheet.Cells(zeile, 1).Value, 1) = "-" Then
ende = zeile
Exit For
End If
Next zeile
'gefundenen Bereich kopieren
ActiveSheet.Range(Cells(anfang, 1), Cells(ende, 1)).EntireRow.Copy Destination:=Worksheets("Summe").Cells(1, 1)
'Nun alle nicht benötigten Zeilen löschen
'Löschen von rückwärts
For zeile = lzeile To 6 Step -1
'alle Zeilen, die hinter Gesamtsumme stehen werden gelöscht
If zeile >= ende Then ActiveSheet.Rows(zeile).Delete
'Alle Zeilen mit Summe löschen
If Left(ActiveSheet.Cells(zeile, 3).Value, 5) = "Summe" Then ActiveSheet.Rows(zeile).EntireRow.Delete
'leere Zeilen löschen
With ActiveSheet.Range(Cells(zeile, 1), Cells(zeile, 19))
If Application.WorksheetFunction.CountBlank(.Cells) = .Cells.Count Then
Rows(zeile).EntireRow.Delete
End If
End With
'Zeilen, die mit - beginnen werden gelöscht
If Left(ActiveSheet.Cells(zeile, 1).Value, 1) = "-" Then ActiveSheet.Rows(zeile).EntireRow.Delete
'Zellen in denen in Spalte A keine Zahl steht werden gelöscht
If Not IsNumeric(ActiveSheet.Cells(zeile, 1)) Then ActiveSheet.Rows(zeile).EntireRow.Delete
'Zellen mit Leerzeichen in Spalte A werden gelöscht
If IsNumeric(ActiveSheet.Cells(zeile, 1)) And ActiveSheet.Cells(zeile, 1).Value = 0 Then ActiveSheet.Rows(zeile).EntireRow.Delete
Next zeile
'Spalte 2 mit WFG löschen
Sheets("Summe").Columns(2).Delete Shift:=xlToLeft
'Im Blatt Summe alle Zeilen löschen, die mit -, A, D oder S anfagen
For zeile = Worksheets("Summe").UsedRange.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
If Left(Worksheets("Summe").Cells(zeile, 1).Value, 1) = "-" Then Worksheets("Summe").Rows(zeile).EntireRow.Delete
If Left(Worksheets("Summe").Cells(zeile, 1).Value, 1) = "A" Then Worksheets("Summe").Rows(zeile).EntireRow.Delete
If Left(Worksheets("Summe").Cells(zeile, 1).Value, 1) = "D" Then Worksheets("Summe").Rows(zeile).EntireRow.Delete
If Left(Worksheets("Summe").Cells(zeile, 1).Value, 1) = "S" Then Worksheets("Summe").Rows(zeile).EntireRow.Delete
'Zeilen löschen, in denen in Spalte I die Buchstaben AS stehen
If Left(Worksheets("Summe").Cells(zeile, 9).Value, 2) = "AS" Then Worksheets("Summe").Rows(zeile).EntireRow.Delete
'Zeilen löschen, die nach VD (in Spalte I) stehen
If Left(Worksheets("Summe").Cells(zeile, 9).Value, 2) = "VD" Then Worksheets("Summe").Range(Cells(zeile + 1, 1), Cells(Worksheets("Summe").UsedRange.SpecialCells(xlCellTypeLastCell).Row, 1)).EntireRow.Delete
Next zeile
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
End Sub
M.O.