Find text characters in cell and add to end

[Hawk04]

Hi: I'm trying to figure out a method in VBA code to find the initials in a text string (name) and add them to the end of the string in the same cell. The format is:

Doe, John

I want to find the J first, D second and add them to the end of the name to show as:

Doe, John (JD)

I have the code written to find the cell with the correct name, but have not figured out the remainder. Here is what I have so far:

    Worksheets("Reg_Scores").Activate
    For PlayerRow = 1 To 50
        Set PlayerCell = Range("B3").Offset(PlayerRow - 1, 0)
        PlayerCell.Select
        If PlayerCell.Text = cmbPlayer.Text Then
            PlayerCell.Activate
            ActiveCell.EntireRow.Copy
            Worksheets("Sub_Scores").Activate
            Range("B3").End(xlDown).Select
            Selection.EntireRow.Insert Shift:=xlDown 'Is it possible to auto populate initials after name, format " (1stlast)"?
            Selection.Offset(0, -1).ClearContents
            Selection.Offset(0, -1).ClearFormats
        Exit For
    End If
    Next PlayerRow

Thanks in advance for any help...

 

[AlphaFrog]

Hi and welcome. Try something like this...

    Dim PlayerCell As Range, Dest As Range
    
    Set Dest = Worksheets("Sub_Scores").Range("B3").End(xlDown)
    
    For Each PlayerCell In Worksheets("Reg_Scores").Range("B3:B53")
        
        If PlayerCell.Text = cmbPlayer.Text Then
            PlayerCell.EntireRow.Copy Destination:=Dest.EntireRow
            Dest = PlayerCell.Value & " (" & Mid(PlayerCell, InStr(1, PlayerCell, ", ", 1) + 2, 1) & Left(PlayerCell, 1) & ")"
            Dest.Offset(0, -1).ClearContents
            Dest.Offset(0, -1).ClearFormats
            Exit For
        End If
        
    Next PlayerCell

 

[Hawk04]

Wonderful! Just what I needed!

Thanks for your help!

 

[AlphaFrog]

You're welcome.