Option Explicit
Type myAreas_Structure
l_Zeile_anf As Long
l_Zeile_end As Long
l_Spalte_anf As Long
l_Spalte_end As Long
End Type
'**********************************************************
Sub Excel_SelectionTexteLoeschen()
'*** Es werden alle selektierten Zellen
'*** auf dem aktiven Blatt untersucht:
'*** a) Inhalt ist eine Zahl
'*** b) Inhalt ist ein Datum
'*** c) In der Zelle ist eine Formel enthalten
'*** Treffen diese Kriterien nicht zu wird der
'*** Zellinhalt gelöscht
'*** Ausgenommen werden Zellen der Zeile 1
'***
'*** Der Makro macht nichts, wenn nur eine Zelle markiert ist
Dim Zelle As Range, ws As Worksheet, r_selection As Range
Set ws = ActiveSheet
If Selection.Count = 1 Then
MsgBox ( _
Es ist nur eine Zelle markiert. & vbLf & _
Es müssen mindestens 2 Zellen markiert sein.)
GoTo AUFRAEUMEN
End If
->Prüfen, ob ganze Spalten oder Zeilen selektiert sind
->ggf. Reduktion auf den benutzten Bereich
Set r_selection = Selection
Call SelectionAufBentuztenBereichEinschraenken(ws)
->über alle markeirten Zellen
For Each Zelle In Selection
->prüfen, auf Zeile <> 1, sonst übergehen
If Zelle.Row <> 1 Then
->leere zellen übergehen
If Zelle.Value <> Then
->prüfen auf nicht Zahl
If Not IsNumeric(Zelle.Value) Then
->prüfen auf nicht Datum
If Not IsDate(Zelle.Value) Then
->prüfen auf enthält keine Formel
If = <> Left(Zelle.Value, 1) Then
->Text löschen
Zelle.Value =
End If
End If
End If
End If
End If
Next
AUFRAEUMEN:
Set Zelle = Nothing: Set ws = Nothing: Set r_selection = Nothing
End Sub
'**********************************************************
Private Function SelectionAufBentuztenBereichEinschraenken(ws As Worksheet)
->*** Eingang: Selection
->*** Ausgang: Selection auf den benutzten Bereich eingeschränkt
Dim l_letzteBenutzteZeile As Long, l_letzteBenutzteSpalte As Long, x As Long
Dim l_Zeile_anf As Long, l_Zeile_end As Long, l_Spalte_anf As Long, l_Spalte_end As Long
Dim r1 As Range, r2 As Range, u As Range
Dim f_Areas() As myAreas_Structure, f_Areas_cnt As Long
->initialisieren
f_Areas_cnt = 0: ReDim f_Areas(1 To 1)
->letzte benutzte Zeile/Spalte feststellen
l_letzteBenutzteZeile = ws.Cells.SpecialCells(xlCellTypeLastCell).Row
l_letzteBenutzteSpalte = ws.Cells.SpecialCells(xlCellTypeLastCell).Column
->über alle Bereiche der Selection
For x = 1 To Selection.Areas.Count
->Bereich-Zeilen-/-Spalten- -Anfang/-Ende bestimmen
l_Zeile_anf = Selection.Areas(x).Row
l_Zeile_end = Selection.Areas(x).Row - 1 + Selection.Areas(x).Rows.Count
l_Spalte_anf = Selection.Areas(x).Column
l_Spalte_end = Selection.Areas(x).Column - 1 + Selection.Areas(x).Columns.Count
->prüfen, ob Bereich innerhalb des benutzten Bereichs liegt
->nein -> dann übergehen
If (l_Zeile_anf <= l_letzteBenutzteZeile) Or _
(l_Spalte_anf <= l_letzteBenutzteSpalte) Then
->Area liegt im benutzten Bereich
->ggf. Ende der selektierten Zeilen reduzieren
If l_Zeile_end > l_letzteBenutzteZeile Then l_Zeile_end = l_letzteBenutzteZeile
->ggf. Ende der selektierten Spalten reduzieren
If l_Spalte_end > l_letzteBenutzteSpalte Then l_Spalte_end = l_letzteBenutzteSpalte
->Bereich merken
f_Areas_cnt = f_Areas_cnt + 1
ReDim Preserve f_Areas(1 To f_Areas_cnt)
f_Areas(f_Areas_cnt).l_Spalte_anf = l_Spalte_anf
f_Areas(f_Areas_cnt).l_Spalte_end = l_Spalte_end
f_Areas(f_Areas_cnt).l_Zeile_anf = l_Zeile_anf
f_Areas(f_Areas_cnt).l_Zeile_end = l_Zeile_end
End If
Next x
->kein Bereich gemerkt? -> 1.Zelle der Selection als Ersatz merken
If f_Areas_cnt = 0 Then
f_Areas_cnt = f_Areas_cnt + 1
ReDim Preserve f_Areas(1 To f_Areas_cnt)
f_Areas(f_Areas_cnt).l_Spalte_anf = Selection.Column
f_Areas(f_Areas_cnt).l_Spalte_end = Selection.Column
f_Areas(f_Areas_cnt).l_Zeile_anf = Selection.Row
f_Areas(f_Areas_cnt).l_Zeile_end = Selection.Row
End If
->Selection neu aufbauen
->Anzahl Bereiche prüfen
If f_Areas_cnt = 1 Then
->nur ein Bereich
->Bereich Selektieren
ws.Range(ws.Cells(f_Areas(1).l_Zeile_anf, f_Areas(1).l_Spalte_anf), _
ws.Cells(f_Areas(1).l_Zeile_end, f_Areas(1).l_Spalte_end)).Select
Else
->1. + 2. Bereich zusammenfassen
With f_Areas(1)
Set r1 = ws.Range(ws.Cells(.l_Zeile_anf, .l_Spalte_anf), ws.Cells(.l_Zeile_end, .l_Spalte_end))
End With
With f_Areas(2)
Set r2 = ws.Range(ws.Cells(.l_Zeile_anf, .l_Spalte_anf), ws.Cells(.l_Zeile_end, .l_Spalte_end))
End With
Set u = Union(r1, r2)
->weiter Bereich anhängen, wenn vorhanden
For x = 3 To f_Areas_cnt
With f_Areas(x)
Set r1 = ws.Range(ws.Cells(.l_Zeile_anf, .l_Spalte_anf), ws.Cells(.l_Zeile_end, .l_Spalte_end))
End With
Set u = Union(u, r1)
Next
->Union selektieren
u.Select
End If
AUFRAEUMEN:
Set r1 = Nothing: Set r2 = Nothing: Set u = Nothing
End Function
