Sub ChangeCaseTagged()
Dim oPara As Paragraph
Dim oRng As Range
    For Each oPara In ActiveDocument.Range.Paragraphs
        Set oRng = oPara.Range
        oRng.End = oRng.End - 1
        If oRng.Text Like "<S*>*" Then
            If Len(oRng.Text) > 0 Then TrueTitleCase oRng
        End If
    Next oPara
lbl_Exit:
    Set oPara = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

Sub TrueTitleCase(rSel As Range)
'Graham Mayor - https://www.gmayor.com - Last updated - 18 Mar 2022
Dim vFindText As Variant
Dim vReplText As Variant
Dim i As Long

    'count the characters in the selected string
    'format the selected string as title case
    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 rSel
        .Case = wdTitleWord
        'omit the first word
        .MoveStart unit:=wdWord, Count:=1
        'list the exceptions to look for in an array
        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
    End With
lbl_Exit:
    Set rSel = Nothing
    Exit Sub
End Sub