Zeilen in bestimmten Bereichen löschen

Hallo
Auf einem Tabellenblatt befinden sich 4 Hauptbereiche. In der im Anhang befindlichen Datei in Spalte A mit A C E G gekennzeichnet. Nun möchte ich, dass in jedem Bereich alle Zeilen die nach der 20. Zeile (im Bereich) eingetragen sind gelöscht werden. Im Anhang mit Schriftfarbe rot markiert. Die Anzahl der Zeilen in allen Bereichen kann aber variieren. Es können also im Bereich mal 100 Zeilen vorhanden sein oder auch nur 10. Sollten es aber über 20 sein sollte incl. der 21 Zeile bis zum nächsten Bereich alles gelöscht werden. Sind es nur 10 Zeilen sein, sollten diese beibehalten werden.
Mit Formatierung oder Suche nach bestimmten Zeichen funktioniert es nicht, da in der Originaltabelle die Formatierungen gleich sind und auch unterschiedlicher Text in den Zellen stehen kann.
Ein Anhaltspunkt wäre vielleicht die Spalte A. Die Einträge dort "A C E G" sind immer gleich.
https://www.herber.de/bbs/user/63284.xls
Ich hoffe Ihr könnt mir da weiterhelfen
MfG Jörg Kaiser

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub Loesche_Rote() Dim Bereich As Range, iCalc As Integer Set Bereich = ActiveSheet.UsedRange With Application iCalc = .Calculation .EnableEvents = False .ScreenUpdating = False .Calculation = xlCalculationManual With Bereich.Offset(0, 1).Columns(Bereich.Columns.Count) .Formula = "=IF(Farbe=3,TRUE,ROW())" ActiveSheet.UsedRange.Sort .Cells(1, 1), xlAscending, , , , , , xlNo On Error Resume Next .SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete On Error GoTo 0 .EntireColumn.Delete End With .EnableEvents = True .ScreenUpdating = True .Calculation = iCalc End With End Sub

Hallo Jörg,
hier noch ein paar Kommentare.

Sub löscheZeilen()
  Dim lngRow As Long, lngLast As Long, lngEnd As Long
  Dim rngDel As Range

  'Startzeile
  lngRow = 2
  'Letzte Zeile bestimmen
  lngEnd = ActiveSheet.UsedRange.Rows.Count

  Do While lngLast + 1 < lngEnd
    'nächsten Eintrag in "A" ermitteln und eine Zeile zurück
    lngLast = Application.Min(lngEnd, Cells(lngRow, 1).End(xlDown).Row - 1)
    'wenn mehr als 20 Zeilen zwischen erstem und letzten Eintrag
    If lngLast >= lngRow + 20 Then
      'zu löschenden Bereich festlegen
      If rngDel Is Nothing Then
        Set rngDel = Range(Cells(lngRow + 20, 1), Cells(lngLast, 1))
      Else
        Set rngDel = Union(rngDel, Range(Cells(lngRow + 20, 1), Cells(lngLast, 1)))
      End If
    End If
    'Startzeile auf den nächsten Eintrag stellen
    lngRow = lngLast + 1
  Loop

  'Bereich löchen
  If Not rngDel Is Nothing Then rngDel.EntireRow.Delete

  Set rngDel = Nothing
End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Zeilen in bestimmten Bereichen löschen

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread