Reducing middle names to initials

[Rhodan1970]

Hi everyone

I am hoping someone can help with this as it is is giving me a headache

column A contains cells each of which contains an individual's full legal name

This name may include 1, 2,3 or even 4 middle names.

I am hoping/looking for a formula/VBA or whatever that would help me reduce cell A1's 'John Joe Richard Smith' in the adjacent cell B1 to 'John J. R. Smith'. Again I stress that the number of middles names do vary.

Concatenate is probably the way to go but I am not seeing it . What I *do* see is 12,754 names that need to be adjusted. I'm this close to suicide by hamster.


help?

 

[SpillerBD]

You can identify where the first name ends by finding the first space.
You can determine how many names are in the field by comparing the length of the named field and the named field after removing the spaces. That will also indicate which space comes before the last name.
The middle initials would then be everything else comprised of the first letter and then each letter proceeded by a space.

now to fulfill that with a UDF...

 

[Fluff]

Are all your names "single" names or can you have "multiple names"?
so could you have something like Joost Heystek van der Westhuizen where Joost is the first name, Heystek a middle name & van der Westhuizen the surname
or maybe Billie Joe McAllister where Billie Joe is the first name & no middle name?

 

[Oaktree]

SpillerBD's approach is how you'd approach this if you were using the SUBSTITUTE worksheet function, but it's easier to use Split() within VBA.

Try putting this in a standard VBA module and calling it with =splitnames(A2) on your spreadsheet:

Function SplitNames(str_input As String)
Dim i As Integer
Dim strArr_split() As String
Dim strOutput As String

strArr_split() = Split(str_input)

For i = LBound(strArr_split()) To UBound(strArr_split())
    
    Select Case i
    
    Case LBound(strArr_split())
        strOutput = strArr_split(i)
    
    Case UBound(strArr_split())
        strOutput = strOutput & " " & strArr_split(i)
    
    Case Else
        strOutput = strOutput & " " & Left(strArr_split(i), 1) & "."
    
    End Select

Next i

SplitNames = strOutput

End Function

 

[mumps]

Try:

Sub test()
    Application.ScreenUpdating = False
    Dim bottomA As Long
    bottomA = Range("A" & Rows.Count).End(xlUp).Row
    Dim cVal As Variant
    Dim rng As Range
    Dim i As Long
    Dim sName As String
    For Each rng In Range("A1:A" & bottomA)
        cVal = Split(rng, " ")
        If UBound(cVal) > 1 Then
            rng.Offset(0, 1) = cVal(0)
            For i = LBound(cVal) + 1 To UBound(cVal) - 1
                sName = rng.Offset(0, 1)
                rng.Offset(0, 1) = sName & " " & Left(cVal(i), 1) & "."
            Next i
        End If
        sName = rng.Offset(0, 1)
        rng.Offset(0, 1) = sName & " " & cVal(UBound(cVal))
    Next rng
    Application.ScreenUpdating = True
End Sub

 

[tonyyy]

If you want to adjust all 12,754 names at once, you might consider the following...

Sub MiddleInitials_1020308()
Dim tmp As Variant
Dim tmp2 As String
Dim arr As Variant
Dim i As Long, j As Long
arr = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
For i = LBound(arr) To UBound(arr)
    tmp = Split(arr(i, 1), " ")
    tmp2 = ""
    For j = LBound(tmp) + 1 To UBound(tmp) - 1
        If tmp2 = "" Then
            tmp2 = Left(tmp(j), 1) & "." & " "
        Else
            tmp2 = tmp2 & Left(tmp(j), 1) & "." & " "
        End If
    Next j
    arr(i, 1) = tmp(0) & " " & tmp2 & tmp(UBound(tmp))
Next i
Range("B1:B" & Cells(Rows.Count, "A").End(xlUp).Row) = arr
End Sub

Cheers,

tonyyy

 

[SpillerBD]

Steeped out for thirty minutes and see 3 promising solutions when I get back. Guess I won't bother with making my own UDF/VBA code suggestion.

Rhodan1970, I hope you take time to test all three out. Looks like they'll all run about as fast.
I most like the formatting of Oaktree as it is a little easier to read, though the others may have been condensed to not take up a lot of web-space.

GJ Ya'll

 

[LockeGarmin]

Another option would be using a Regex UDF. Just put in the following code:

Function RE_REPLACE(Source As String, Pattern As String, Replacement As String, _ 
                       Optional IgnoreCase As Boolean, Optional MultiLine As Boolean) As String
  
  RE_REPLACE = GetRegex(Pattern, True, IgnoreCase, MultiLine).Replace(Source, Replacement)

End Function

Private Function GetRegex(Pattern As String, IsGlobal As Boolean, IgnoreCase As Boolean, MutliLine As Boolean) As Object
  
Static Regex As Object

  If Regex Is Nothing Then Set Regex = CreateObject("VBScript.Regexp")
  
  Regex.Pattern = Pattern
  Regex.Global = IsGlobal
  Regex.IgnoreCase = IgnoreCase
  Regex.MultiLine = MutliLine
  
  Set GetRegex = Regex
  
End Function

And enter this formula:

=RE_REPLACE(A1,"(\b\s+(?!\w+\s*$)\w)\w*", "$1.")

Or this formula:

=RE_REPLACE(TRIM(A1),"(\s(?!\w+$)\w)\w*", "$1.")

Regex in this case is a little more outlandish, but it was still a fun exercise!

 

[Rhodan1970]

Thank you all very much, I see light at the end of the tunnel. I'll name my unborn children after you all ! ( not too sure about 'fluffs' tho)

Thanks guys I really appreciate the help, Tony's in particular because it turned a asylum chore into a breeze

 

[tonyyy]

You're very welcome. Glad it worked out...