Moin!

HIer eine geänderte Variante. In meinem Test wird auch die Formel eingetragen. Das hängt aber davon ab, ob nach dem Löschen in Spalte F noch was steht. Nur dann wird eine Formel eingetragen. Die sieht dann so aus: =(D2-(F2*-1000/C2))/(F2*-1000/C2)

Habe sie jetzt noch gelb markiert, damit man erkennt wo sie eingetragen wurde. Sollte die letzte Spalte sein, die sich das Programm selber raussucht.

VG

Sub zeilen_löschen()
'löscht bestimmte Zeilen nach voragben
Dim farbe As Long
Dim bla As Variant
Dim zeilenanzahl As Long
Dim quelltab As Object
Dim zeile As Long
Dim neublatt As Boolean
Dim neu As Object
Dim letztespalte As Long
Dim blattname As String
Dim löschen As Range
Dim formel As String

Application.ScreenUpdating = False
'werte festlegen
Set quelltab = ActiveWorkbook.Worksheets("Reporting")
farbe = 43  'grün, ggf. anpassen
bla = "irgendwas"
neublatt = False
blattname = "NeuesBlatt"
Set löschen = Union(quelltab.Columns(4), quelltab.Columns("F:L"), quelltab.Columns("N:Y"), quelltab.Columns(27))

zeilenanzahl = quelltab.UsedRange.Rows.Count

'alle Zeilen durchgehen
For zeile = zeilenanzahl To 2 Step -1
    If quelltab.Cells(zeile, 1).Interior.ColorIndex = farbe Or quelltab.Cells(zeile, 2) = bla Or quelltab.Cells(zeile, 2) = "" Then
        quelltab.Rows(zeile).Delete
    Else
        'Prüfung auf 0 und dann kopieren
        If quelltab.Cells(zeile, 6) = 0 Then
            'Prüfung ob das Blatt schon eingefügt wurde
            If neublatt = False Then
                Set neu = ActiveWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
                neu.Name = blattname
                quelltab.Select
                quelltab.Rows(1).Copy neu.Cells(1, 1)
                neublatt = True
            End If
            
            'kopieren
            neu.Rows("2").Insert Shift:=xlDown
            quelltab.Rows(zeile).Copy neu.Cells(2, 1)
            quelltab.Rows(zeile).Delete
        End If
    End If
Next zeile

'löschen
löschen.Delete

If neublatt = True Then
    Set löschen = Union(neu.Columns(4), neu.Columns("F:L"), neu.Columns("N:Y"), neu.Columns(27))
    löschen.Delete
End If
'nochmal die Werte anpassen
letztespalte = quelltab.UsedRange.Columns.Count + 1
zeilenanzahl = quelltab.UsedRange.Rows.Count
'Formel eintragen

For zeile = zeilenanzahl To 2 Step -1
    formel = "=(D" & zeile & "-(F" & zeile & "*-1000/C" & zeile & "))/(F" & zeile & "*-1000/C" & zeile & ")"
    If quelltab.Cells(zeile, 6) <> 0 Then
        quelltab.Cells(zeile, letztespalte).FormulaLocal = formel
        quelltab.Cells(zeile, letztespalte).Interior.ColorIndex = 6
    End If
Next zeile

Application.ScreenUpdating = True
End Sub