Option Explicit
Sub Excel_StrasseHausnummerTrennen()
-> Trennt Straße/Hausnummer
-> - Straßenbezeichnung bleibt in der jeweiligen Zelle erhalten
-> - Hausnummer wird in der rechts danebenliegenden Zelle abgelegt
->
-> Vor dem Aufruf ist die Spalte oder Teile dieser zu markieren.
-> Es folgt eine Abfrage, ob eine neue Spalte für Hausnummer
-> rechts neben der markierten Spalte eingefügt werden soll.
->
-> Es muß mehr als eine Zelle markiert werden.
->
Dim ret As Integer, r As Range, Zelle As Range
Dim l_Spalte As Long, l_leerCnt As Long
Dim s_StrHnr As String, s_Str As String, s_HNr As String
->markierten Bereich merken
Set r = Selection
->nur eine Zelle selektiert
If r.Count = 1 Then
MsgBox (Es muß mehr als eine Zelle markiert sein.)
GoTo AUFRAEUMEN
End If
->mehr als eine Spalte selektiert
If r.Columns.Count <> 1 Then
MsgBox (Es darf nur eine Spalte oder Teile davon selektiert werden.)
GoTo AUFRAEUMEN
End If
l_Spalte = r.Column
ret = MsgBox( _
Trennen von Straße/Hausnummer & vbLf & vbLf & _
Die Hausnummern werden in der Zelle rechts neben der jeweils selektierten abgelegt. & vbLf & _
Soll dafür rechts neben der markierten Spalte eine neue Spalte eingefügt werden ?, _
vbQuestion + vbDefaultButton2 + vbYesNoCancel)
If ret = vbCancel Then Exit Sub
If ret = vbYes Then
->Spalte einfügen
On Error Resume Next
Columns(l_Spalte + 1).Insert Shift:=xlToRight
If Err.Number <> 0 Then
Err.Clear
MsgBox ( _
Eine neue Spalte konnte nicht eingefügt werden. & vbLf & _
Die könnte an verbundenen Zelle liegen.)
GoTo AUFRAEUMEN
End If
->als Text formatieren
Columns(l_Spalte + 1).NumberFormat = @
On Error GoTo 0
End If
->Für alle selektierten Zellen
l_leerCnt = 0
For Each Zelle In r
s_StrHnr = Zelle.Value
->nur noch leer Zellen?
If s_StrHnr = Then
l_leerCnt = l_leerCnt + 1
->10 leere Zellen -> Ende
If l_leerCnt > 10 Then GoTo AUFRAEUMEN
Else
l_leerCnt = 0
End If
->Straße/Hausnummer trennen
Call StrasseHausnummerTrennen(s_StrHnr, s_Str, s_HNr)
Cells(Zelle.Row, Zelle.Column) = s_Str
Cells(Zelle.Row, Zelle.Column + 1) = s_HNr
Next
AUFRAEUMEN:
Set r = Nothing: Set Zelle = Nothing
End Sub
'****************************************************************
Private Function StrasseHausnummerTrennen( _
s_StrHnr As String, _
s_Str As String, _
s_HNr As String)
->getrennt wird ab der ersten Zahl
Dim pos As Long, s As String, x As Long
->erste Zahl suchen
pos = 0
For x = 1 To Len(s_StrHnr)
s = Mid(s_StrHnr, x, 1)
Select Case s: Case 0 To 9: pos = x: Exit For: End Select
Next
->Hausnummer vorhanden ?
If pos <> 0 Then
pos = pos - 1
s_Str = Trim(Left(s_StrHnr, pos))
s_HNr = Right(s_StrHnr, Len(s_StrHnr) - pos)
Else
s_Str = s_StrHnr
s_HNr =
End If
End Function
