Hi Marrick,
Try the following. One of my aims has been getting the 'TrueTitleCase' module coded so that it doesn't depend on being within a table. The main issue with the data you've been working with is that it seems to me a given cell may have one or more sentences, each of which needs to be processed separately. Equally, if the first row has two cells, each is a separate sentence and would need to be processed separately. Of course, I may be wrong on both counts and each row might only ever have one sentence. To handle that, I've been using the sentences collection as you know.
There are two problems with using the sentences collection, the first of which is that Word's idea of a sentence isn't necessarily what you or I would think of as a sentence. For example, any abbreviation terminated by a period (such as Mr., Mrs., etc.) is counted by VBA as a sentence. So far it doesn't seem that's an issue. The second problem is that, where table cells are concerned, it seems Word collapses the sentence range to just the cell marker is if doesn't find a character like '.' or '?' and the cell is the last one on the row. That's why my previous coding for the sentences collection didn't work properly with your data - mine had the periods and/or rows with two or more cells.
Code:
Sub TrueTitleCase(Rng As Range)
Dim RngTxt As Range, ArrTxt(), i As Long, j As Long
'list the exceptions to look for in an array
ArrTxt = Array("A", "An", "And", "As", "At", "But", "By", _
"For", "If", "In", "Of", "On", "Or", "The", "To", "With")
With Rng
For i = 1 To .Sentences.Count
Set RngTxt = .Sentences(i)
With RngTxt
.End = .End - 1
If .Information(wdWithInTable) And .Start = .End Then
.MoveStart wdCell, -1
.End = .End - 1
End If
.MoveStart wdWord, 1
With .Find
'replace items in the list
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Format = False
.MatchCase = True
For j = LBound(ArrTxt) To UBound(ArrTxt)
.Text = ArrTxt(j)
.Replacement.Text = LCase(ArrTxt(j))
.Execute Replace:=wdReplaceAll
Next j
End With
While InStr(.Text, ":") > 0
.MoveStartUntil ":", wdForward
.Start = .Start + 1
.MoveStartWhile " ", wdForward
.Words.First.Case = wdTitleWord
Wend
End With
Next i
End With
End Sub
FWIW, I've previously coded a much more elaborate 'ProperCase' function you may be interested in:
http://www.techsupportforum.com/foru...-a-643881.html. This one handles surnames beginning with Mc, Mac & O' as well.