True Title Case for First Row of All Tables

macropod · #10 12-10-2013, 06:24 PM

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.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Task Indicator - All predecessors complete true/false, y/n	jdove78	Project	2	10-10-2012 05:53 PM
IF formula returns TRUE instead of evaluating COUNTIF	ColinC	Excel	4	12-28-2011 08:21 AM
Another Case of Automatic/Zombie Formatting of Tables	MKummerfeldt	Word Tables	0	10-31-2011 10:40 AM
Macro not staying true	oluc	Word VBA	4	11-21-2010 08:10 AM
From all UPPER CASE to Proper Case	davers	Word	1	04-30-2009 12:41 PM