Sub ConvertToProperCase()
Dim cell As Range
For Each cell In Selection
cell.Value = ProperCase(cell.Value, bCaps:=True, bClos:=True, bExcl:=True)
Next
End Sub
Function ProperCase(StrTxt As Variant, Optional bCaps As Boolean, Optional bClos As Boolean, Optional bExcl As Boolean) As String
'Convert an input string to proper-case.
'Surnames like O', Mc & Mac and hyphenated names are converted to proper case also.
'If bCaps = True, then upper-case strings like ABC are preserved; otherwise they're converted.
'If bClos = False, words in the exclusion list after closing characters are retained as lower-case; otherwise they're converted.
'If bExcl = True, words in the exclusion list are retained as lower-case, unless after specified punctuation marks.
Dim i As Long, j As Long, k As Long, l As Long, bFnd As Boolean
Dim StrChr As String, StrExcl As String, StrMac As String, StrPunct As String, StrTmpA As String, StrTmpB As String
'General exclusion list.
StrExcl = "(a),a,am,an,and,are,as,at,(b),be,but,by,(c),can,cm,(d),did,do,does,(e),eg,en,eq,etc,(f),for," & _
"(g),get,go,got,(h),has,have,he,her,him,how,(i),ie,if,in,into,is,it,its,(j),(k),(l),(m),me,mi," & _
"mm,my,(n),na,nb,no,not,(o),of,off,ok,on,one,or,our,out,(p),(q),(r),re,(s),she,so,(t),the," & _
"their,them,they,this,to,(u),(v),via,vs,(w),was,we,were,who,will,with,would,(x),(y),yd,you,your,(z)"
'Mac name lower-case list.
StrMac = "Macad,Macau,Macaq,Macaro,Macass,Macaw,Maccabee,Macedon,Macerate,Mach,Mack,Macle,Macrame,Macro,Macul,Macumb"
StrPunct = "!,;,:,.,?,/,(,{,[,<,“,"""
If bClos = True Then StrPunct = StrPunct & ",),},],>,”"
If bExcl = False Then
StrExcl = ""
StrPunct = ""
Else
StrExcl = " " & Replace(Trim(StrExcl), ",", " , ") & " "
End If
If Len(Trim(StrTxt)) = 0 Then
ProperCase = StrTxt
Exit Function
End If
If bCaps = False Then StrTxt = LCase(StrTxt)
StrTxt = " " & StrTxt & " "
For i = 1 To UBound(Split(StrTxt, " ")) - 1
StrTmpA = Split(StrTxt, " ")(i)
'Check for a double-quote before the word
If Left(StrTmpA, 1) Like "[""“”]" Then
StrTmpB = UCase(Left(StrTmpA, 2)) & Right(StrTmpA, Len(StrTmpA) - 2)
Else
StrTmpB = UCase(Left(StrTmpA, 1)) & Right(StrTmpA, Len(StrTmpA) - 1)
End If
StrTmpB = " " & StrTmpB & " "
StrTmpA = " " & StrTmpA & " "
StrTxt = Replace(StrTxt, StrTmpA, StrTmpB)
Next
'Code for handling hyphenated words
For i = 1 To UBound(Split(StrTxt, "-"))
StrTmpA = Split(StrTxt, "-")(i)
StrTmpB = UCase(Left(StrTmpA, 1)) & Right(StrTmpA, Len(StrTmpA) - 1)
StrTxt = Replace(StrTxt, StrTmpA, StrTmpB)
Next
'Code for handling family names starting with O'
For i = 1 To UBound(Split(StrTxt, "'"))
If InStr(Right(Split(StrTxt, "'")(i - 1), 2), " ") = 1 Or _
Right(Split(StrTxt, "'")(i - 1), 2) = Right(Split(StrTxt, "'")(i - 1), 1) Then
StrTmpA = Split(StrTxt, "'")(i)
StrTmpB = UCase(Left(StrTmpA, 1)) & Right(StrTmpA, Len(StrTmpA) - 1)
StrTxt = Replace(StrTxt, StrTmpA, StrTmpB)
End If
Next
'Code for handling family names starting with Mc
If Left(StrTxt, 2) = "Mc" Then
Mid(StrTxt, 3, 1) = UCase(Mid(StrTxt, 3, 1))
End If
i = InStr(StrTxt, " Mc") + InStr(StrTxt, """Mc")
If i > 0 Then
Mid(StrTxt, i + 3, 1) = UCase(Mid(StrTxt, i + 3, 1))
End If
'Code for handling family names starting with Mac
If InStr(1, StrTxt, "Mac", vbBinaryCompare) > 0 Then
For i = 1 To UBound(Split(StrTxt, " "))
StrTmpA = Split(StrTxt, " ")(i)
If InStr(1, StrTmpA, "Mac", vbBinaryCompare) > 0 Then
StrTmpA = Left(StrTmpA, Len(StrTmpA) - InStr(1, StrTmpA, "Mac", vbBinaryCompare) + 1)
bFnd = False
For j = 0 To UBound(Split(StrMac, ","))
StrTmpB = Split(StrMac, ",")(j)
If Left(StrTmpA, Len(StrTmpB)) = StrTmpB Then
bFnd = True
Exit For
End If
Next
If bFnd = False Then
If Len(Split(Trim(StrTmpA), " ")(0)) > 4 Then
StrTmpB = StrTmpA
Mid(StrTmpB, 4, 1) = UCase(Mid(StrTmpB, 4, 1))
StrTxt = Replace(StrTxt, StrTmpA, StrTmpB)
End If
End If
End If
Next
End If
'Code to restore excluded words to lower case
If StrExcl <> "" Then
For i = 0 To UBound(Split(StrExcl, ","))
StrTmpA = Split(StrExcl, ",")(i)
StrTmpB = UCase(Left(StrTmpA, 2)) & Right(StrTmpA, Len(StrTmpA) - 2)
If InStr(StrTxt, StrTmpB) > 0 Then
StrTxt = Replace(StrTxt, StrTmpB, StrTmpA)
'Make sure an excluded words following punctution marks are given proper case anyway
For j = 0 To UBound(Split(StrPunct, ","))
StrChr = Split(StrPunct, ",")(j)
StrTxt = Replace(StrTxt, StrChr & StrTmpA, StrChr & StrTmpB)
Next
End If
Next
End If
ProperCase = Trim(StrTxt)
End Function
