Tipp 0473 Leere Zeilen in Auswahl löschen
Autor/Einsender:
Datum:
  Alexander Fross
25.11.2005
Entwicklungsumgebung:   Excel 2000
In der Prozedur Initialize_DeleteBlankRows werden alle leeren Zeilen (entweder mit keinem Inhalt oder mit dem Wert 0) gelöscht. Dabei werden nur die aktuell selektierten Zellen berücksichtigt. Das bedeutet, es werden alle Zeilen gelöscht, die markierte Zellen aufweisen, die keinen Inhalt oder den Wert 0 haben.
Wenn beispielsweise in einer Zeile drei Zellen markiert sind und eine davon den Wert 'Hallo' beinhaltet, wird diese Zeile nicht gelöscht. Erst wenn alle drei Zellen entweder leer sind oder den Wert 0 beinhalten, wird die Zeile gelöscht.
Einsatzmöglichkeiten dieser Prozedur sind zum Beispiel Listen, in denen ein oder mehrere Spalten numerische Werte aufweisen. Mit dieser Prozedur kann man all jene Datensätze, die in allen numerischen Spalten entweder 0 oder keinen Inhalt enthalten, löschen. Dabei kann die aktuelle Auswahl durch selektieren von mehreren Tabellen, auf die gesamte Arbeitsmappe angewendet werden.
Das Download-Beispiel ist sehr ausführlich kommentiert!
 
Option Explicit

Public Sub Initialize_DeleteBlankRows()
  Dim lngCount    As Long
  Dim strSelAdr   As String
  Dim strCellAdr  As String
  Dim strMsgTxt   As String
  Dim blnRows()   As Boolean

  Dim objRng      As Range
  Dim objCell     As Range
  Dim objSh       As Object
  Dim xlCalcMode  As XlCalculation

  If Check_Exit(Selection) Then Exit Sub

  On Error GoTo err_DeleteBlankRows
  strSelAdr = Selection.Address(0, 0, xlA1, 0)

  xlCalcMode = Application.Calculation
  Call Enable_ScreenUpdate(False, xlCalculationManual)

  For Each objSh In ActiveWindow.SelectedSheets
    If TypeOf objSh Is Worksheet Then
      Set objRng = objSh.Range(strSelAdr) _
            .SpecialCells(xlCellTypeVisible)
      Set objRng = Application.Intersect(objSh.UsedRange, objRng)

      If Not objRng Is Nothing Then
        blnRows = Get_RowsIndex(objRng)

        Set objCell = objRng.Find("*", , xlValues, xlPart)
        If Not objCell Is Nothing Then
          strCellAdr = objCell.Address
          Do
            If objCell.Value <> 0 Then
              blnRows(objCell.Row) = False
            End If
            Set objCell = objRng.FindNext(objCell)
          Loop Until objCell.Address = strCellAdr
        End If

        Call Delete_Rows(objSh, blnRows, lngCount)
      End If
    End If
  Next objSh

  Call Enable_ScreenUpdate(True, xlCalcMode)

  strMsgTxt = "Es wurden " & _
        Replace(Format(lngCount, "#,##0 "), "0 ", "keine ") & _
        "Zeilen gelöscht!"
  MsgBox strMsgTxt, vbExclamation, "Leere Zeilen"

  Exit Sub

err_DeleteBlankRows:
  MsgBox "Es ist ein Fehler aufgetreten!" & vbCr & vbCr & _
         "Quelle" & vbTab & Err.Source & vbCr & _
         "Fehler" & vbTab & Err.Description, vbCritical, _
         "Fehler " & Err.Number
End Sub

Private Function Get_RowsIndex(ByRef rRng As Range) As Boolean()
  Dim i           As Long
  Dim j           As Long
  Dim lngAreas()  As Long
  Dim blnRows()   As Boolean

  ReDim lngAreas(rRng.Areas.Count, 1) As Long

  lngAreas(0, 0) = rRng.Worksheet.Rows.Count
  lngAreas(0, 1) = 1

  For i = 1 To rRng.Areas.Count
    With rRng.Areas(i)
      lngAreas(i, 0) = .Cells(1, 1).Row
      If lngAreas(0, 0) > lngAreas(i, 0) Then
        lngAreas(0, 0) = lngAreas(i, 0)
      End If
      lngAreas(i, 1) = .Cells(.Rows.Count, 1).Row
      If lngAreas(0, 1) < lngAreas(i, 1) Then
        lngAreas(0, 1) = lngAreas(i, 1)
      End If
    End With
  Next i

  ReDim blnRows(lngAreas(0, 0) - 1 To lngAreas(0, 1)) As Boolean
  For i = 1 To UBound(lngAreas, 1)
    For j = lngAreas(i, 0) To lngAreas(i, 1)
      blnRows(j) = True
    Next j
  Next i

  Get_RowsIndex = blnRows
End Function

Private Sub Delete_Rows(ByRef rWks As Worksheet, ByRef rbRows() _
      As Boolean, ByRef rlCount As Long)

  Dim i As Long
  Dim j As Long

  For i = UBound(rbRows) To (LBound(rbRows) + 1) Step -1
    If rbRows(i) Then
      If rbRows(i - 1) Then
        j = j + 1
      Else
        rWks.Range(rWks.Rows(i), rWks.Rows(i + j)).Delete
        rlCount = rlCount + j + 1
        j = 0
      End If
    End If
  Next i
End Sub

Private Function Check_Exit(ByRef rSelection As Object) As Boolean
  Const s_TITLE   As String = "Leere Zeilen löschen?"
  Const s_TEXT    As String = _
          "Leere Zeilen der aktuellen Selektion wirklich löschen?"
  Const i_OPTION  As Integer = _
          vbQuestion + vbYesNo + vbDefaultButton2

  If Not TypeOf rSelection Is Range Then
    Check_Exit = True
  ElseIf Not rSelection.Cells.Count > 1 Then
    Check_Exit = True
  ElseIf MsgBox(s_TEXT, i_OPTION, s_TITLE) <> vbYes Then
    Check_Exit = True
  End If
End Function

Private Sub Enable_ScreenUpdate(ByVal vbEnable, _
      ByVal vCalcMode As XlCalculation)
  Application.Calculation = vCalcMode
  Application.EnableEvents = vbEnable
  Application.ScreenUpdating = vbEnable
End Sub
 
Weitere Links zum Thema
Leere Zeilen in einer Tabelle löschen

Windows-Version
95
98
ME
NT
2000
XP
Vista
Win 7
Excel-Version
95
97
2000
2002 (XP)
2003
2007
2010


Download  (75 kB) Downloads bisher: [ 638 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Samstag, 27. August 2011