Intelligent Title Case

I love this macro, but I noticed today that it doesn't work when I run it on text in a table cell. For some reason, the value of Selection.Range.Words.Count is returned as 1 no matter how many words are in the selection range. However, if I take the text string out of the table, the macro works correctly. Anyone know why that would be or how to fix it?

Thanks Ken, appreciate it! I'm still learning :)

Lee,

Your macro goes into an endless loop if Track Changes and Show Markup are on. This could be avoided by inserting after the Dim statements:

ActiveDocument.TrackRevisions = False
ActiveWindow.View.ShowRevisionsAndComments = False

Editor’s clients often specify that any changes be highlighted using Track Changes. Neither Allen’s or Lee’s macros will do that.

for what it's worth, here's my take - thanks to Allen for the inspiration :)

Private Sub Tools_Set_Heading_Title_Case()
'
' affects ALL document content
'
' set expected 'proper' case for each heading
' find and set upper case where required
' find and set lower case where required
' reapply style to heading in case someone originally created the style as 'all caps'/'small caps'
' as we still want to see the 'proper' case in the navigation pane
'
' https://word.tips.net/T000215_Intelligent_Title_Case.html
' https://cybertext.wordpress.com/2011/07/01/word-macro-to-change-headings-to-sentence-case/
'
Dim objStyle As Style
Dim arrTargetStyles(), arrTargetAllUpperCaseWords(), arrTargetAllLowerCaseWords()
Dim varCounter As Variant, arrUWord As Variant, arrLWord As Variant

arrTargetStyles = Array("Heading 1", "Heading 2", "Heading 3", "Heading 4")
arrTargetAllUpperCaseWords = Array("AS ", "CBTS", "CF", "CPU", "HMI", "HSTS", "LDS", "NTP", "PLC", "RCA", "RS LDS", "RS-LDS", "SD", "VSS", "WMS")
arrTargetAllLowerCaseWords = Array(" and ", " for ", " of ", " on ", " the ", " to ")

For Each varCounter In arrTargetStyles
With Selection.Find
.ClearFormatting
.Wrap = wdFindContinue
.Forward = True
.Format = True
.MatchWildcards = False
.Text = ""
.Style = ActiveDocument.Styles(varCounter)
.Execute

While .found
'Selection.Select
'Debug.Print "Configuring "; varCounter; " "; Selection.Text
' set title case
Selection.Range.Case = wdTitleWord
' find and fix upper case matching words
For Each arrUWord In arrTargetAllUpperCaseWords
If InStr(1, Selection.Text, arrUWord, vbTextCompare) > 0 Then
Selection.Text = Replace(Selection.Text, arrUWord, UCase(arrUWord), 1, 1, vbTextCompare)
End If
Next arrUWord
' find and fix lower case matching words
For Each arrLWord In arrTargetAllLowerCaseWords
If InStr(1, Selection.Text, arrLWord, vbTextCompare) > 0 Then
Selection.Text = Replace(Selection.Text, arrLWord, LCase(arrLWord), 1, 1, vbTextCompare)
End If
Next arrLWord
' reapply style to heading
Selection.Style = varCounter
Selection.Collapse Direction:=wdCollapseEnd
.Execute
Wend
End With
Next varCounter

Set objStyle = Nothing
Set varCounter = Nothing
Erase arrTargetStyles
Erase arrTargetAllUpperCaseWords
Erase arrTargetAllLowerCaseWords

Selection.GoTo What:=wdGoToSection, Which:=wdGoToFirst

'Debug.Print "Finished!"
End Sub

I'm trying to do this for PowerPoint but I can only find a way to apply title case to slide titles. I cannot seem to figure out the proper way to title-case selected text like that which exists in the text boxes and content sections.