Namen heraus

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Public Sub Separieren() Dim lZeile As Long Dim vTemp As Variant Dim iTemp As Integer Dim iLaenge As Integer Dim sZeichen As String Dim sText As String Application.ScreenUpdating = False With ThisWorkbook.Worksheets("Tabelle1") ' den Tabellenblattnamen ggf. anpassen! .Range("B2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row).ClearContents For lZeile = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row If Trim$(.Range("A" & lZeile).Value) "" Then vTemp = Split(.Range("A" & lZeile).Value, " ") For iTemp = LBound(vTemp) To UBound(vTemp) vTemp(iTemp) = Trim$(vTemp(iTemp)) If Not IsNumeric(Left(vTemp(iTemp), 1)) Then sText = "" For iLaenge = 1 To Len(vTemp(iTemp)) sZeichen = Mid(vTemp(iTemp), iLaenge, 1) If Not IsNumeric(sZeichen) Then If sText = "" Then sText = sZeichen Else sText = sText & sZeichen End If Else Exit For End If Next iLaenge If Len(sText) > 1 Then If .Range("B" & lZeile).Value = "" Then .Range("B" & lZeile).Value = sText Else .Range("B" & lZeile).Value = .Range("B" & lZeile).Value & _ " " & sText End If End If End If Next iTemp End If Next lZeile End With Application.ScreenUpdating = True End Sub

Hallo Jorgi,
hier noch eine elegante Lösung mit regular Expressions

Option Explicit
'    bei den Verweisen muss ggf. Microsoft VBSript Regular Expressions 5.5 aktiviert sein
Public Sub Namen_Extrakt()
Dim RegEx   As Object
Dim lZeile  As Long
Dim vTemp   As Variant
Dim iTemp   As Integer
Dim sText   As String
Set RegEx = CreateObject("VBScript.Regexp")
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Tabelle1") ' den Tabellenblattnamen ggf. anpassen!
.Range("B2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row).ClearContents
For lZeile = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
vTemp = Split(.Range("A" & lZeile).Value, " ") ' am Leerzeichen trennen
For iTemp = 0 To UBound(vTemp)
'              nur alle 29 Groß-/Klein-Buchstaben, das ß und den Bindestrich zulassen
With RegEx
.Pattern = "[^a-zA-ZäöüßÄÖÜ-]"
.Global = True
sText = .Replace(vTemp(iTemp), "") ' ungewünschte Zeichen löschen
End With
If Len(sText) > 2 Then ' nur Wörter länger 2 Stellen übernehmen
If .Range("B" & lZeile).Value = "" Then
.Range("B" & lZeile).Value = sText ' den ersten Namensteil übertragen
Else                                 ' alle weiteren Namensteile übergeben
.Range("B" & lZeile).Value = .Range("B" & lZeile).Value & " " & sText
End If
End If
Next iTemp
Next lZeile
End With
Application.ScreenUpdating = True
Set RegEx = Nothing ' die Ressource wieder freigeben
End Sub

Gruß Peter

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread