Automatisiert Zeilen löschen?

Hallo!
Ich arbeite an einem Sheet mit 1711 Zeilen. Die erste Zeile beinhaltet die Spaltenüberschriften.
Danach beginnt mein Problem:
Immer je drei Zeilen beziehen sich auf einen Datensatz. Pro Datensatz benötige ich aber lediglich immer
die erste Zeile. Die Zeilen 2 und 3 jedes Datensatzes möchte ich gerne löschen.
Beispiel:
Zeile
1 Spaltenüberschriften
2 Datensatz1 - behalten
3 Datensatz 1 - löschen
4 Datensatz 1 - löschen
5 Datensatz 2 - behalten
6 Datensatz 2 - löschen
7 Datensatz 2 - löschen
..........
...........
Alle zu löschenden Zeilen per Hand zu löschen möchte ich nur ungern ;-)) tun. Zumal ich ähnliche Sheets
auf 8 Arbeitsblättern habe.......
Kann man da irgendetwas automatisieren?
Gruss aus Hannover!
Michael

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub loeschen() Dim lLetzte As Long Dim lZeile As Long Application.ScreenUpdating = False With Worksheets("Tabelle1") lLetzte = .Cells(Rows.Count, 1).End(xlUp).Row For lZeile = lLetzte To 2 Step -3 Rows(lZeile - 0).Delete Shift:=xlUp Rows(lZeile - 1).Delete Shift:=xlUp Next lZeile End With Application.ScreenUpdating = True End Sub

Hallo Micheal,
probier mal. (bezieht sich immer auf das gerade aktive Tabellenblatt!)
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Duplikate()
Dim lngR As Long, intC As Integer

On Error GoTo ErrExit
GMS

With ActiveSheet
    lngR = .Cells(Rows.Count, 1).End(xlUp).Row
    intC = .Cells(1, Columns.Count).End(xlToLeft).Column + 1

    .Cells(1, intC) = "###"

    .Range(.Cells(2, intC), .Cells(lngR, intC)).Formula = _
        "=COUNTIF($A$2:A2,A2)<>1"

    .Range(.Cells(2, intC), .Cells(lngR, intC)) = _
        .Range(.Cells(2, intC), .Cells(lngR, intC)).Value

    .Range("A1").CurrentRegion.Sort _
        key1:=.Cells(1, intC), _
        order1:=xlDescending, _
        header:=xlYes

    .Range("A1").AutoFilter _
        Field:=intC, _
        Criteria1:="=true"

    On Error Resume Next
    .Range(.Cells(2, 1), .Cells(lngR, intC)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    Err.Clear
    On Error GoTo ErrExit

    .Columns(intC).Delete

    .Range("A1").AutoFilter

    .Range("A1").CurrentRegion.Sort _
        key1:=.Cells(1, 1), _
        order1:=xlAscending, _
        header:=xlYes

End With

ErrExit:
If Err.Number <> 0 Then MsgBox Err.Number & vbLf & Err.Description
GMS True

End Sub

Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long

With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Modus Then
        .Calculation = IIf(lngCalc <> 0, lngCalc, xlCalculationAutomatic)
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread