How to keep the UPPERCASE part, discarding/deleting the lowercase in a selection, with macros?

[Kwawa]

I have to deal frequently with data containing a column with several names written like this:

SURNAME Name
DOE John
DE NIRO Robert
SMITH Robert James

I need to rewrite them al in this format:

SURNAME N.
DOE J.
DE NIRO R.
SMITH R.J.

So I need to keep intact the uppercase part and put a dot after every first letter on the name/s.
How should I arrange a macro (or a sequence of macros) to do this?

 

[RobP]

Hi, welcome to the forum.

Would something like this do for you ? (I should add that I assume names are all in Col A, and be careful, as I output them in my test to Column G at the end. But you can switch to Col A to overwrite originals if you wish). Just dont overwrite any of your data off to the right in Col G ...

Sub name_change()

Dim input_name As String
Dim nameArray() As String

lastrow = ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row 'use Col A (1) to check for last row number

For x = 1 To lastrow

    input_name = Range("A" & x)
  
    nameArray = Split(input_name, " ") 'put the input name into an array of names
 
    no_of_names = (UBound(nameArray(), 1)) + 1 '(array starts at zero, so add 1 for counting)
     
    lastname = nameArray(0) & " " 'lastname is always in Caps, so store it from the first array element(0)
  
    For y = 1 To no_of_names - 1 'set this count to loop through each name in the cell
  
        If (nameArray(y) <> UCase(nameArray(y))) Then 'if the name is not uppercase,
            nameArray(y) = Left(nameArray(y), 1) 'then delete all characters except the initial
        End If
      
        If (Len(nameArray(y)) > 1) Then nameArray(y) = nameArray(y) & " " 'add a " " after the name if its NOT an initial
      
        lastname = lastname & nameArray(y) 'append the name, or initial onto the lastname to build the final answer
      
    Next y
  
    lastname = lastname & "." 'all names completed, so add the "." at the end
    Range("G" & x).Value = lastname 'show it in col G.
Next x

End Sub

 

[Snakehips]

@Kwawa Welcome.
Not a lot different to Rob's solution above. I've done it so I'll post it.
If the names that you quote are typical and you wish to re-write a column of names then maybe like below.

Dim Arry As Variant
Dim c As Long
Dim lr As Long
Dim cell As Range

'Assumes names in column A edit to suit
lr = Range("A" & Rows.Count).End(xlUp).Row
    For Each cell In Range("A2:A" & lr)
        Arry = Split(cell, " ")
            For c = 0 To UBound(Arry)
                If Not Arry(c) = UCase(Arry(c)) Then
                    Arry(c) = Left(Arry(c), 1) & "."
                    Else: Arry(c) = Arry(c) '& " "
                End If
            Next
        cell = Join(Arry)
    
    Next cell
End Sub

 

[RobP]

.. I also just added another check in case somehow you have a list of "mixed" names ie. some that are processed already, versus new ones added to the bottom

Sub name_change()

Dim input_name As String
Dim nameArray() As String

lastrow = ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row 'use Col A (1) to check for last row number

For x = 1 To lastrow

    input_name = Range("A" & x)
    If (Right(input_name, 1) <> ".") Then 'check to see if name was processed previously
    
        nameArray = Split(input_name, " ") 'put the input name into an array of names
        no_of_names = (UBound(nameArray(), 1)) + 1 '(array starts at zero, so add 1 for counting)
       
        lastname = nameArray(0) & " " 'lastname is always in Caps, so store it from the first array element(0)
    
        For y = 1 To no_of_names - 1 'set this count to loop through each name in the cell
            If (nameArray(y) <> UCase(nameArray(y))) Then 'if the name is not uppercase,
                nameArray(y) = Left(nameArray(y), 1) 'then delete all characters except the initial
            End If
            If (Len(nameArray(y)) > 1) Then nameArray(y) = nameArray(y) & " " 'add a " " after the name if its NOT an initial
            lastname = lastname & nameArray(y) 'append the name, or initial onto the lastname to build the final answer
        Next y
    
        lastname = lastname & "." 'all names completed, so add the "." at the end
        Range("G" & x).Value = lastname 'show it in col G.
    
    End If
    
Next x

End Sub

 

[Kwawa]

Hi Rob and Snake, thanks for the welcome first of all.
All provided macros above work like a charm.

I owe you both a cup of coffee!!!

 

[RobP]

you're welcome, and thanks for the feedback.

Rob