Zeilen löschen

Bild

Betrifft: Zeilen löschen
von: Benny
Geschrieben am: 18.02.2005 11:46:38
Hallo,
ich habe ein Makro welches mir die letzte aktive Zeile ermittelt. Dann werden alle vorhergehenden Zeilen geprüft ob in der Spalte A ein Eintrag vorhanden ist. Dort wo es in Spalte A keinen Eintrag gibt wird diese Zeile gelöscht.


Sub loesche_Leerzeilen()
   Dim ActRow, LastRow
   LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
   ActRow = 1
   While (ActRow < LastRow)
      If (IsEmpty(Cells(ActRow, 1))) Then
        Rows(ActRow).Delete
        LastRow = LastRow - 1
      Else
         ActRow = ActRow + 1
     End If
   Wend
End Sub

Nun möchte ich das Makro abwandeln.
Es soll in einem Range("A4:E15") oder Rows("4:15") geprüft werden ob es dort Leerzellen oder Leerzeilen gibt und nur in diesem Range bzw. Row sollen diese dann gelöscht werden.
Wer kann mir dort helfen.
Vielen Dank
Benny
Bild

Betrifft: AW: Zeilen löschen
von: Uduuh
Geschrieben am: 18.02.2005 12:19:51
Hallo,
meinst du das so?
Wenn irgendeine Zelle in Spalte A:E der Zeile leer ist, wird die Zeile gelöscht.

Sub loesche_Leerzeilen()
   Dim ActRow, LastRow
   LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
   ActRow = 1
   While (ActRow < LastRow)
      If application.worksheetfunction.counta(Range(cells(actrow,1),cells(actrow,5)))<5 Then
        Rows(ActRow).Delete
        LastRow = LastRow - 1
      Else
         ActRow = ActRow + 1
     End If
   Wend
End Sub

Gruß aus'm Pott
Udo

Bild

Betrifft: AW: Zeilen löschen
von: Benny
Geschrieben am: 18.02.2005 12:33:41
Hallo Udo,
nein so war es nicht gemeint. Trotzdem vielen Dank. Die andere Antwort vom Werner hat genau das Ergebnis geliefert welches ich brauchte.
Vielen dank für deine Mühe.
Gruß
Benny
Bild

Betrifft: AW: Zeilen löschen
von: WernerB.
Geschrieben am: 18.02.2005 12:20:21
Hallo Benny,
wie gefällt Dir das?

Sub Benny()
Dim i As Long
    Application.ScreenUpdating = False
    For i = 15 To 4 Step -1
      If WorksheetFunction.CountA(Rows(i)) = 0 Then
        Rows(i).Delete
      End If
    Next i
    Application.ScreenUpdating = True
End Sub

Viel Erfolg wünscht
WernerB.
P.S.: Dieses Forum lebt auch von den Rückmeldungen der Fragesteller an die Antworter !
Bild

Betrifft: AW: Zeilen löschen
von: Benny
Geschrieben am: 18.02.2005 12:40:55
Hallo Werner,
vielen Dank du hast das Problem genau erkannt und deine Lösung ist sofort einsetzbar.
Bitte erkläre mir warum "For i = 15 To 4 Step -1" rückwärts gezählt wird und man nicht von Zeile 4 - 15 vorwärts zählt.
Des weiteren würde ich gerne wenn dieses Worksheet abgearbeitet ist, die gleiche Prozedur noch in einem weiteren Worksheet ablaufen lassen. Jedoch habe ich pro Worksheet zwei Zeilenbereiche die ich prüfen lassen möchte, nämlich Zeile 4-15 und 44-55. Nachdem die Leerzeilen dann entfernt wurden sollen diese übrig gebliebenen Zeilen in ein neues Worksheet kopiert werden.
Hast du da vielleicht auch eine prakmatische Lösung für mich.
Danke für die Mühe
Gruß
Benny
Bild

Betrifft: AW: Zeilen löschen
von: WernerB.
Geschrieben am: 18.02.2005 13:17:56
Hallo Benny,
wenn man die Zeilen von oben nach unten abarbeitet, wird bei aufeinander folgenden Leerzeilen wegen der von unten nachrückenden Zeilen die eine oder andere übersprungen; dies kann bei der Abarbeitung in umgekehrter Richtung nicht passieren.
Hier das gewünschte Beispiel-Makro:

Sub Benny()
Dim i As Long, _
    z1 As Byte, z2 As Byte
    Application.ScreenUpdating = False
    With Worksheets("Tabelle1")
      z1 = 15
      For i = 15 To 4 Step -1
        If WorksheetFunction.CountA(.Rows(i)) = 0 Then
          z1 = z1 - 1
          .Rows(i).Delete
        End If
      Next i
    End With
    With Worksheets("Tabelle2")
      z2 = 55
      For i = 55 To 44 Step -1
        If WorksheetFunction.CountA(.Rows(i)) = 0 Then
          z2 = z2 - 1
          .Rows(i).Delete
        End If
      Next i
    End With
    Sheets.Add After:=Sheets(Sheets.Count)
    Worksheets("Tabelle1").Range("A4:IV" & z1).Copy _
      Destination:=Worksheets(Sheets.Count).Range("A1")
    Application.CutCopyMode = False
    Worksheets("Tabelle2").Range("A44:IV" & z2).Copy _
      Destination:=Worksheets(Sheets.Count).Range("A" & z1 - 2)
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Gruß
WernerB.
Bild

Betrifft: AW: Zeilen löschen
von: Benny
Geschrieben am: 18.02.2005 14:01:21
Hallo Werner,
echt super wie viel Mühe du dir machst. Ich meinte mit den beiden Zeilenbereichen das sie jeweils immer in einem Worksheet vorkommen und das pro Workshett. Diesbezgl. habe ich das Makro geändert, ist das so OK.


Sub Benny()
Dim i As Long, _
    z1 As Byte, z2 As Byte
    Application.ScreenUpdating = False
    With Worksheets("Tabelle1")
      z1 = 15
      For i = 15 To 4 Step -1
        If WorksheetFunction.CountA(.Rows(i)) = 0 Then
          z1 = z1 - 1
          .Rows(i).Delete
        End If
      Next i
      z2 = 55
      For i = 55 To 44 Step -1
        If WorksheetFunction.CountA(.Rows(i)) = 0 Then
          z2 = z2 - 1
          .Rows(i).Delete
        End If
      Next i
    End With
    With Worksheets("Tabelle2")
      z1 = 15
      For i = 15 To 4 Step -1
        If WorksheetFunction.CountA(.Rows(i)) = 0 Then
          z1 = z1 - 1
          .Rows(i).Delete
        End If
      Next i
      z2 = 55
      For i = 55 To 44 Step -1
        If WorksheetFunction.CountA(.Rows(i)) = 0 Then
          z2 = z2 - 1
          .Rows(i).Delete
        End If
      Next i
    End With
    Sheets.Add After:=Sheets(Sheets.Count)
    Worksheets("Tabelle1").Range("A4:IV" & z1).Copy _
      Destination:=Worksheets(Sheets.Count).Range("A1")
    Application.CutCopyMode = False
    Worksheets("Tabelle2").Range("A44:IV" & z2).Copy _
      Destination:=Worksheets(Sheets.Count).Range("A" & z1 - 2)
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Ich habe auch noch die ein oder andere Frage.
Was bedeutet Range("A44:IV" & z2), fehlt bei IV nicht etwas?
Wo werden die nicht leeren Zeilen der Tabelle1 und Tabelle2, z.B. hintereinander in Tabelle 3 kopiert?
Hoffe das ich mich nicht zu dumm anstelle.
Gruß
Martin
Bild

Betrifft: AW: Zeilen löschen
von: WernerB.
Geschrieben am: 18.02.2005 14:51:55
Hallo Benny!
1. "IV" ist die letzte Spalte im Tabellenblatt, die Variable "z2" beinhaltet die entsprechende Zeilennummer.
2. Die nicht leeren Zeilen der Tabellen1 und 2 werden in ein neu erstelltes Tabellenblatt hintereinander ab Zeile 1 kopiert.
3. Hier das Makro:

Sub Benny()
Dim i As Long, laR As Long, _
    z1 As Byte, z2 As Byte, z3 As Byte, j As Byte
    Application.ScreenUpdating = False
    Sheets.Add After:=Sheets(Sheets.Count)
    For j = 1 To 2
      With Worksheets("Tabelle" & j)
        z1 = 15
        z3 = 44
        For i = 15 To 4 Step -1
          If WorksheetFunction.CountA(.Rows(i)) = 0 Then
            z1 = z1 - 1
            z3 = z3 - 1
            .Rows(i).Delete
          End If
        Next i
        z2 = z3 + 11
        For i = z3 + 11 To z3 Step -1
          If WorksheetFunction.CountA(.Rows(i)) = 0 Then
            z2 = z2 - 1
            .Rows(i).Delete
          End If
        Next i
      End With
      With Worksheets(Sheets.Count)
        On Error Resume Next
        laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
        If laR = 1 And .Cells(1, 1).Value = "" Then laR = 0
        On Error GoTo 0
        Worksheets("Tabelle" & j).Range("A4:IV" & z1).Copy _
          Destination:=.Range("A" & laR + 1)
        Application.CutCopyMode = False
        On Error Resume Next
        laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
        On Error GoTo 0
        Worksheets("Tabelle" & j).Range("A" & z3 & ":IV" & z2).Copy _
          Destination:=.Range("A" & laR + 1)
        Application.CutCopyMode = False
      End With
    Next j
    Application.ScreenUpdating = True
End Sub

Gruß und schönes WE
WernerB.
Bild

Betrifft: Korrektur
von: WernerB.
Geschrieben am: 18.02.2005 15:08:41
Hallo Martin/Benny,
bitte entferne diese Zeile aus dem Makro; sie ist unnötig und könnte u.U. einen Fehler verursachen:
If laR = 1 And .Cells(1, 1).Value = "" Then laR = 0
Danke!

Gruß
WernerB.
Bild

Betrifft: AW: Korrektur
von: Benny
Geschrieben am: 21.02.2005 08:09:58
Hallo Werner,
hoffe du hattest noch ein schönes Wochenende,
Leider funktioniert das Makro nicht.
Ich bekomme einen Laufzeitfehler '9':
Index außerhalb des gültigen Bereiches
Wenn ich dann auf Debuggen klicke bleibt der Cursor bei - With Worksheet ("Tabelle1" & j) stehen. Liegt das vielleicht an der Benennung meiner Blätter?
Ich habe die Excel-Datei einmal mit angehangen.
https://www.herber.de/bbs/user/18409.xls
Es wäre prima wenn du sie noch einmal prüfen würdest. Danke für deine Mühe.
Liebe Grüße
Martin
Bild

Betrifft: AW: Korrektur
von: WernerB.
Geschrieben am: 21.02.2005 09:20:58
Hallo Benny,
das Makro habe ich jetzt auf Deine Tabellenblattbezeichnungen angepasst.
Allerdings verstehe ich die Sinnhaftigkeit, die Zeilen 4-15 sowie 44-55 in beiden Blättern auf Inhalte zu überprüfen, überhaupt nicht
.
Außerdem weise ich darauf hin, dass Zellen, die Formeln enthalten, nicht "leer" sind, auch wenn die Formeln die Ausgabe von Leerzeichen bewirken.
Zudem verwendest Du verbundene Zellen, die die Funktion eines Makros erheblich beeinträchtigen können.

Sub losche_Leerzeilen_kopiere_Rest()
Dim i As Long, laR As Long, _
    z1 As Byte, z2 As Byte, z3 As Byte, j As Byte
    Application.ScreenUpdating = False
    Sheets.Add After:=Sheets(Sheets.Count)
    For j = 1 To 2
      With Worksheets("0" & j)
        z1 = 15
        z3 = 44
        For i = 15 To 4 Step -1
          If WorksheetFunction.CountA(.Rows(i)) = 0 Then
            z1 = z1 - 1
            z3 = z3 - 1
            .Rows(i).Delete
          End If
        Next i
        z2 = z3 + 11
        For i = z3 + 11 To z3 Step -1
          If WorksheetFunction.CountA(.Rows(i)) = 0 Then
            z2 = z2 - 1
            .Rows(i).Delete
          End If
        Next i
      End With
      With Worksheets(Sheets.Count)
        On Error Resume Next
        laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
        On Error GoTo 0
        Worksheets("0" & j).Range("A4:IV" & z1).Copy _
          Destination:=.Range("A" & laR + 1)
        Application.CutCopyMode = False
        On Error Resume Next
        laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
        On Error GoTo 0
        Worksheets("0" & j).Range("A" & z3 & ":IV" & z2).Copy _
          Destination:=.Range("A" & laR + 1)
        Application.CutCopyMode = False
      End With
    Next j
    Application.ScreenUpdating = True
End Sub

Gruß
WernerB.
Bild

Betrifft: AW: Korrektur
von: Benny
Geschrieben am: 21.02.2005 15:14:47
Hallo Werner,
nach einigen Tests und verändern diverser Werte, ist das Makro nun fast so wie gewünscht. Deine Frage nach der Sinnhaftigkeit erklärt sich dadurch, dass ich nicht wußte das ein abprüfen einer Zeile auf "Leer" auch auf Formeln greift.
Nun würde ich das Makro noch ein bißchen ausbauen wollen.
Die weiteren Schritte in dem neuen Tabellenblatt stelle ich mir wie folgt vor:
1.) umbenennen den neuen Tabellenblattes in SuS
2.) Spalte A markieren
3.) Bearbeiten - Gehe zu - Inhalte - Leerzellen anklicken
4.) Bearbeiten - Zellen löschen - Ganze Zeile
5.) Sortieren nach Spalte F - B - A (wenn möglich, ansonsten auflösen der Formatierung, dann sortieren und zum Schluss die Formatierung wieder übertragen)
Das würde ich über einen Makrorkorder aufzeichnen und in das u.a. Makro integrieren. Jedoch habe ich beim sortieren so meine Schwierigkeiten. Kannst du mir auch dort helfen.

Sub losche_Leerzeilen_kopiere_Rest()
Dim i As Long, laR As Long, _
    z1 As Byte, z2 As Byte, z3 As Byte, j As Byte
    Application.ScreenUpdating = False
    Sheets.Add After:=Sheets(Sheets.Count)
    For j = 1 To 2
      With Worksheets("0" & j)
        z1 = 41
        z3 = 53
        For i = 41 To 6 Step -1
          If WorksheetFunction.CountA(.Rows(i)) = 0 Then
            z1 = z1 - 1
            z3 = z3 - 1
            .Rows(i).Delete
          End If
        Next i
        z2 = z3 + 36
        For i = z3 + 12 To z3 Step -1
          If WorksheetFunction.CountA(.Rows(i)) = 0 Then
            z2 = z2 - 1
            .Rows(i).Delete
          End If
        Next i
      End With
      With Worksheets(Sheets.Count)
        On Error Resume Next
        laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
        On Error GoTo 0
        Worksheets("0" & j).Range("A4:IV" & z1).Copy _
          Destination:=.Range("A" & laR + 1)
        Application.CutCopyMode = False
        On Error Resume Next
        laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
        On Error GoTo 0
        Worksheets("0" & j).Range("A" & z3 & ":IV" & z2).Copy _
          Destination:=.Range("A" & laR + 1)
        Application.CutCopyMode = False
      End With
    Next j
    Application.ScreenUpdating = True
End Sub

Viele Grüße
Benny
Bild

Betrifft: AW: Korrektur
von: WernerB.
Geschrieben am: 22.02.2005 07:53:46
Hallo Benny,
ich hoffe, das klappt so wie gewünscht:

Sub losche_Leerzeilen_kopiere_Rest()
Dim Adr As String, _
    i As Long, laR As Long, _
    z1 As Byte, z2 As Byte, z3 As Byte, j As Byte
    Application.ScreenUpdating = False
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).name = "SuS"
    For j = 1 To 2
      With Worksheets("0" & j)
        z1 = 41
        z3 = 53
        For i = 41 To 6 Step -1
          If WorksheetFunction.CountA(.Rows(i)) = 0 Then
            z1 = z1 - 1
            z3 = z3 - 1
            .Rows(i).Delete
          End If
        Next i
        z2 = z3 + 36
        For i = z3 + 12 To z3 Step -1
          If WorksheetFunction.CountA(.Rows(i)) = 0 Then
            z2 = z2 - 1
            .Rows(i).Delete
          End If
        Next i
      End With
      With Worksheets(Sheets.Count)
        On Error Resume Next
        laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
        On Error GoTo 0
        Worksheets("0" & j).Range("A4:IV" & z1).Copy _
          Destination:=.Range("A" & laR + 1)
        Application.CutCopyMode = False
        On Error Resume Next
        laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
        On Error GoTo 0
        Worksheets("0" & j).Range("A" & z3 & ":IV" & z2).Copy _
          Destination:=.Range("A" & laR + 1)
        Application.CutCopyMode = False
      End With
    Next j
    With Worksheets(Sheets.Count)
      On Error Resume Next
      laR = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
      On Error GoTo 0
      If laR = 0 Then Exit Sub
      .Range("A1:A" & laR).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
      Adr = .Cells(.Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row, _
        .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column).Address
      .Range("A1:" & Adr).Sort Key1:=.Range("F1"), Order1:=xlAscending, Key2:=.Range("B1"), _
        Order2:=xlAscending, Key3:=.Range("A1"), Order3:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
    End With
    Application.ScreenUpdating = True
End Sub

Gruß
WernerB.
Bild

Betrifft: AW: Korrektur
von: Benny
Geschrieben am: 22.02.2005 08:31:43
Hallo Werner,
leider bleibt das Makro an der u.a. Stelle mit folgender Fehlermeldung stehen.
Laufzeitfehler (1004)
Für diese Aktionen müssen alle verbundenen Zellen dieselbe Größe haben
.Range("A1:" & Adr).Sort Key1:=.Range("F1"), Order1:=xlAscending, Key2:=.Range("B1"), _
Order2:=xlAscending, Key3:=.Range("A1"), Order3:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
Was wäre wenn man erst die Formatierung löst dann sortiert und hinterher die Formatierung wieder setzt.
Oder es wird das Blatt SuS erst in SuS1 kopiert, dann dort die Formatierung gelöst, sortiert und die Formatierung von SuS übernommen. Danach wird das Blatt SuS gelöscht und SuS1 in SuS umbenannt.
Sorry aber kannst du mir auch dabei helfen.
Gruß
Benny
Bild

Betrifft: AW: Korrektur
von: WernerB.
Geschrieben am: 22.02.2005 10:02:48
Hallo Benny,
auf mögliche Makro-Probleme im Zusammenhang mit verbundenen Zellen habe ich Dich bereits hingewiesen.
Grundsätzlich weigere ich mich auch, hier irgendwelche diesbezügliche zeitraubende Experimente durchzuführen, zumal kein befriedigendes Ergebnis garantiert werden kann.

Gruß
WernerB.
Bild

Betrifft: AW: Korrektur
von: Benny
Geschrieben am: 22.02.2005 10:13:49
Hallo Werner,
noch einmal vielen Dank für deine Ausdauer und bisherige Mühe. Ich freue mich sehr das du mir so weit helfen konntest, bis demnächst.
Noch eine erfolgreiche Woche.

Gruß
Benny
 Bild

Beiträge aus den Excel-Beispielen zum Thema "Zeilen löschen"