Option Explicit
Sub LeereZellenLoeschenShiftLeft()
'*** im selektierten Bereich leere Zellen löschen und
'*** nachfolgende nach links verschieben
'***
'*** selektierter Bereich darf nur aus einem Bereich bestehen.
'*** Mehrfach Selektion ist nicht zulässig
Dim ws As Worksheet, r As Range
Dim lRowAnf As Long, lRowEnd As Long
Dim lColAnf As Long, lColEnd As Long
Dim z As Long, sp As Long
Dim bLeereZelleLoeschen As Boolean
Set r = Selection
Set ws = ActiveSheet
If r.Count = 1 Then MsgBox Nur eine Zelle selektiert.: GoTo AUFRAEUMEN
If r.Areas.Count > 1 Then MsgBox mehrfache Selektion nicht erlaubt.: GoTo AUFRAEUMEN
->nur benutzten Bereich untersuchen
Set r = Application.Intersect(r, ws.UsedRange)
If r Is Nothing Then MsgBox nichts im benutzten Bereich selektiert.: GoTo AUFRAEUMEN
->Zeile von/bis, Spalte von/bis
lRowAnf = r.Row
lRowEnd = r.Row + r.Rows.Count - 1
lColAnf = r.Column
lColEnd = r.Column + r.Columns.Count - 1
->Bildschirm-Update abschalten
Application.ScreenUpdating = False
->Zeileweise abarbeiten
For z = lRowAnf To lRowEnd
bLeereZelleLoeschen = False
->Spalten von rechts nach links abarbeiten
For sp = lColEnd To lColAnf Step -1
If Not bLeereZelleLoeschen Then
If ws.Cells(z, sp).Value <> Then bLeereZelleLoeschen = True
Else
If ws.Cells(z, sp).Value = Then
ws.Range(ws.Cells(z, sp), ws.Cells(z, sp)).Delete Shift:=xlToLeft
End If
End If
Next
Next
->Bildschirm-Update anschalten
Application.ScreenUpdating = True
AUFRAEUMEN:
Set ws = Nothing: Set r = Nothing
End Sub
