Thema: Zellbereiche löschen

StandardModule: basMain

' Löschen aller leeren Zellen einer Spalte

Sub DeleteEmptyCells()
   Dim intLastRow As Integer
   Dim intRow As Integer
   intLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
   For intRow = intLastRow To 1 Step -1
      If Application.CountA(Rows(intRow)) = 0 Then
         intLastRow = intLastRow - 1
      Else
         Exit For
      End If
   Next intRow
   For intRow = intLastRow To 1 Step -1
      If IsEmpty(Cells(intRow, 1)) Then
         Cells(intRow, 1).Delete xlShiftUp
      End If
   Next intRow
End Sub

' Löschen der Zeile, wenn Zelle in Spalte A leer ist

Sub DeleteRowIfEmptyCell()
   Dim intRow As Integer, intLastRow As Integer
   intLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
   For intRow = intLastRow To 1 Step -1
      If Application.CountA(Rows(intRow)) = 0 Then
         intLastRow = intLastRow - 1
      Else
         Exit For
      End If
   Next intRow
   For intRow = intLastRow To 1 Step -1
      If IsEmpty(Cells(intRow, 1)) Then
         Rows(intRow).Delete
      End If
   Next intRow
End Sub

' Löschen aller leeren Zeilen

Sub DeleteEmptyRows()
   Dim intRow As Integer, intLastRow As Integer
   intLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
   For intRow = intLastRow To 1 Step -1
      If Application.CountA(Rows(intRow)) = 0 Then
         Rows(intRow).Delete
      End If
   Next intRow
End Sub

' FehlerZellen leeren

Sub ClearContentsErrorCells()
   On Error GoTo ERRORHANDLER
   Cells.SpecialCells(xlCellTypeFormulas, 16).ClearContents
ERRORHANDLER:
End Sub

' FehlerZellen löschen

Sub ClearErrorCells()
   On Error GoTo ERRORHANDLER
   Cells.SpecialCells(xlCellTypeFormulas, 16).Delete xlShiftUp
ERRORHANDLER:
End Sub

' Löschen aller Zellen in Spalte A mit "hallo" im Text

Sub DeleteQueryCells()
   Dim var As Variant
   Do While Not IsError(var)
      var = Application.Match("hallo", Columns(1), 0)
      If Not IsError(var) Then Cells(var, 1).Delete xlShiftUp
   Loop
End Sub

' Leeren aller Zelle mit gelbem Hintergrund

Sub ClearYellowCells()
   Dim rng As Range
   For Each rng In ActiveSheet.UsedRange
      If rng.Interior.ColorIndex = 6 Then
         rng.ClearContents
      End If
   Next rng
End Sub

' Alle leeren Zellen löschen

Sub DeleteEmptys()
   Dim rng As Range
   Application.ScreenUpdating = False
   For Each rng In ActiveSheet.UsedRange
      If IsEmpty(rng) Then rng.Delete xlShiftUp
   Next rng
   Application.ScreenUpdating = True
End Sub

Beiträge aus dem Excel-Forum zu den Themen Allgemein und Bereich