Gruppe
Allgemein
Bereich
Bereich
Thema
Zellbereiche löschen
Problem
Eine Reihe von Beispielen zum Löschen oder Leeren von Zellbereichen nach verschiedenen Kriterien.
Lösung
Geben Sie den Code in ein Standardmodul ein und weisen die einzelnen Prozeduren Schaltflächen zu.
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