Meier* unterstreichen und * entfernen

[luna101]

Hallo Forum,
habe ein kleines Problem und bitte um Hilfe.
Ich habe eine Vornamenliste mit mehreren Namen in einer Zelle.
Wenn bei einem Vornamen ein * steht zB. (Meier*), dann sollte
der Vorname (links vom Stern) unterstrichen und der * entfernt werden.
Habe es mit Text in Spalten usw. versucht, aber nicht hingekriegt.
Wäre froh, wenn mir jemand helfen würde.
Mit freundlichen Grüssen
Martin

[Fennek]

Hallo,

um die anderen etwas zu motivieren sage ich mal: Es geht nicht perfekt!

Code:

Sub F_en()

y = Columns(1).Replace(Chr(160), Chr(32))
For i = 2 To cells(Rows.Count, 1).Row
    pos = InStr(1, cells(i, 1), "*")
    If pos Then
        cells(i, "L") = cells(i, 1)
        Do
            p1 = InStrRev(Left(cells(i, 1), pos), " ")
            cells(i, "L") = Replace(cells(i, "L"), "*", "", , 1)
            If p1 < 0 Then p1 = 1
            cells(i, "L").Characters(p1, pos - p1).Font.Underline = xlUnderlineStyleSingle
            pos = InStr(1, cells(i, "L"), "*")
        Loop Until pos = 0
    End If
Next i
End Sub

In den Zeilen mit 2 "Sternchen" wird nur ein Name unterstrichen.

mfg

[luna101]

Fennek
wenn auch nicht ganz perfekt, das nimmt mir schon einige Arbeit ab.
Eventuell hat noch jemand ein Vorschlag wie man das machen kann,
sonst werde ich den Rest von hand bereinigen.
Werde mal ein wenig damit üben.
Mit dankbarem Gruss
Martin

[Mase]

Versuch mal folgendes:

Code:

    Dim lngEnd              As Long
    Dim lngStart            As Long
    Dim c                   As Excel.Range
   
    Const sSuchzeichen      As String = "*"
    Const sTrennzeichen     As String = " "
   
   
    For Each c In Range("A2", Cells(Rows.Count, 1).End(xlUp))
   
        With c
            While InStrRev(.Value, sSuchzeichen) > 0
           
                lngEnd = InStrRev(.Value, sSuchzeichen)
               
                lngStart = InStrRev(.Value, sTrennzeichen, lngEnd)
               
                .Characters(lngStart + 1, lngEnd - lngStart - 1).Font.Underline = True
                .Characters(lngEnd, 1).Delete
               
            Wend
        End With
       
    Next

[luna101]

Marco,
funktioniert einwandfrei.
Das ist
Besten Dank und Gruss
Martin