Function TitleCase(StrTxt As String, 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 title 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
  TitleCase = 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
TitleCase = Trim(StrTxt)
End Function

Sub MakeTitle()
Application.ScreenUpdating = False
Dim StrTmp As String
With Selection.Range
  StrTmp = Trim(.Text)
  While Right(StrTmp, 1) = "."
    StrTmp = Left(StrTmp, Len(StrTmp) - 1)
  Wend
  While InStr(StrTmp, "  ") > 0
    StrTmp = Replace(StrTmp, "  ", " ")
  Wend
  StrTmp = TitleCase(StrTmp, bCaps:=False, bExcl:=False)
  .Text = StrTmp
End With
Application.ScreenUpdating = True
End Sub

Sub HeadingMakeTitle()
Application.ScreenUpdating = False
Dim StrTmp As String
With ActiveDocument.Range
  With .Find
    .MatchWildcards = True
    .ClearFormatting
    .Replacement.ClearFormatting
    .Format = True
    .Wrap = wdFindStop
    .Execute Replace:=wdReplaceAll
    .Style = "Heading 1"
    .Text = "[!^13]{1,}"
    .Replacement.Text = ""
    .Execute
  End With
  Do While .Find.Found
    StrTmp = Trim(.Text)
    While Right(StrTmp, 1) = "."
      StrTmp = Left(StrTmp, Len(StrTmp) - 1)
    Wend
    While InStr(StrTmp, "  ") > 0
      StrTmp = Replace(StrTmp, "  ", " ")
    Wend
    StrTmp = TitleCase(StrTmp, bCaps:=False, bExcl:=False)
    .Text = StrTmp
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
End Sub

Sub TrueTitleCase()  ' Graham Mayor
'   Graham Mayor vba examples page 2
'   Creates true title case - sort of
'   See http://www.gmayor.com/word_vba_examples_2.htm
'   2014-01-31 - tab formatting added to vba by ckk
'
    Dim sText As range, vFindText As Variant, vReplText As Variant, _
        i As Long, k As Long, m As Long
        '
    Set sText = Selection.range
    'count the characters in the selected string
    k = Len(sText)
    If k < 1 Then
        'If none, then no string is selected
        'so warn the user
        MsgBox "Select the text first!", vbOKOnly, "No text selected"
        Exit Sub 'and quit the macro
    End If
    'format the selected string as title case
    sText.Case = wdTitleWord
    'list the exceptions to look for in an array
    vFindText = Array("A", "An", "And", "As", "At", "But", "By", "For", _
    "If", "In", "Of", "On", "Or", "The", "To", "With")
    'list their replacements in a matching array
    vReplText = Array("a", "an", "and", "as", "at", "but", "by", "for", _
    "if", "in", "of", "on", "or", "the", "to", "with")
    With sText
        With .Find
            'replace items in the first list
            'with the corresponding items from the second
            .ClearFormatting
            .Replacement.ClearFormatting
            .Forward = True
            .Wrap = wdFindStop
            .MatchWholeWord = True
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Format = True
            .MatchCase = True
            For i = LBound(vFindText) To UBound(vFindText)
                .Text = vFindText(i)
                .Replacement.Text = vReplText(i)
                .Execute Replace:=wdReplaceAll
            Next i
        End With
        'Reduce the range of the selected text
        'to encompass only the first character
        .MoveEnd Unit:=wdCharacter, Count:=-Len(sText) + 1
        'format that character as upper case
        .Case = wdUpperCase
        'restore the selected text to its original length
        .MoveEnd Unit:=wdCharacter, Count:=k
        'and check to see if the string contains a colon
        If InStr(1, sText, ":") > 0 Then
            'If it does note the position of the character
            'after the first colon
            m = InStr(1, sText, ":") + 1
            'and set that as the new start of the selected text
            .MoveStart wdCharacter, m
            'set the end of the selected text to include
            'one extra character
            .MoveEnd Unit:=wdCharacter, Count:=-Len(sText) + 1
            'format that character as upper case
            .Case = wdUpperCase
        End If
    End With
  End Sub

    Let StrExcl = "(a),a,an,and,as,at,(b),be,but,by,(c),cm,(d),(e),eg,en,eq,etc,(f),for," & _
              "(g),(h),(i),ie,in,into,(j),(k),(l),(m)," & _
              "mm,(n),na,nb,(o),of,off,on,or,(p),(q),(r),re,(s),(t),the," & _
              "to,(u),(v),via,vs,(w),with,(x),(y),yd,(z)"