Alter Proper Case Macro

[Tim Hanson]

Hello,

I want to convert the Names in a column to proper case but I do not want to change there titles.

The macro converts cell content to proper case up to the first ","

BOB FEGESON
Sally Ran, Ph.D.
GREG HYMAN, MA, CPCC​

To

Bob Fegeson
Sally Ran, Ph.D.
Greg Hyman, MA, CPCC​

This almost works, but it gives Betty H.Whitney as Betty H.whitney and Hank O'Day as Hank O'day

Is there a way to alter this code to take these into account

Thanks

Sub FindChr()
    Dim ws As Worksheet
    Dim myRange As Range, cell As Range
    Dim tmpString As String
    Dim MyString As Variant
    Dim i As Long

    '~~> Change this to the relevant worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    With ws
        Set myRange = .Range("D2", .Range("D" & .Rows.Count).End(xlUp))

        For Each cell In myRange
            If InStr(1, cell.Formula, ",") Then
                MyString = Split(cell.Formula, ",")

                tmpString = StrConv(MyString(0), vbProperCase)

                For i = 1 To UBound(MyString)
                    tmpString = tmpString & "," & MyString(i)
                Next i

                cell.Formula = tmpString
            Else
                cell.Formula = StrConv(cell.Formula, vbProperCase)
            End If
        Next cell
    End With
End Sub

 

[NARAYANK991]

Hi Tim ,

Change the following statement :

cell.Formula = StrConv(cell.Formula, vbProperCase)

to :

cell.Formula = Application.WorksheetFunction.Proper(cell.Formula)

Narayan

 

[Tim Hanson]

Narayan, that worked!! its late my head in tired.

Thank you

 

[Tim Hanson]

One last edit was needed, on further inspection of the results I was getting Bob O'Day, Pd.D >> Bob O'day, Ph.d

and this fixed it tmpString = StrConv(MyString(0), vbProperCase) needs to be tmpString = Application.WorksheetFunction.Proper(MyString(0))

Here is the final code

Sub ProperCase()
    Dim ws As Worksheet
    Dim myRange As Range, cell As Range
    Dim tmpString As String
    Dim MyString As Variant
    Dim i As Long

    '~~> Change this to the relevant worksheet
    Set ws = Sheets("Source")

    With ws
        Set myRange = .Range("D2", .Range("D" & .Rows.Count).End(xlUp))

        For Each cell In myRange
            If InStr(1, cell.Formula, ",") Then
                MyString = Split(cell.Formula, ",")

                tmpString = Application.WorksheetFunction.Proper(MyString(0))

                For i = 1 To UBound(MyString)
                    tmpString = tmpString & "," & MyString(i)
                Next i

                cell.Formula = tmpString
            Else
                'cell.Formula = StrConv(cell.Formula, vbProperCase)
                cell.Formula = Application.WorksheetFunction.Proper(cell.Formula)
            End If
        Next cell
    End With
End Sub