True Title Case for First Row of All Tables

[Marrick13]

I have a macro I found online that sets “true title case” for any text that’s selected (it places articles such as “a”, “an”, “the”, etc. in lower case unless they are at the beginning of the text as an alternative to Word’s case-changing function). It works very well when the text whose case is to be changed to title case is selected.

I am trying to get this to work for the first row text of all tables in a document, but not having success. The “FormatAllTables” macro is my attempt to achieve this, and it selects the first row of each table, then calls “TrueTitleCase” to handle the case work. I know it’s not good practice to use the selection method, but I’ve other approaches, such as trying to capture just the text instead of the whole row, and been unable to make it work. My early attempts did change the case of the first row of each table, but whenever the first word was one that is in the TrueTitleCase array, it was changed to lower case. I believe this is because the “.MoveEnd Unit:=wdCharacter, Count:=-Len(sText) + 1” line works only when the text is manually selected (so that only the text is highlighted instead of the whole row), but I can’t get the macro to select only the text as it loops through the first row of each table, and I haven’t come up with an alternative to selecting the row that works.

The current version shown here handles the first row properly, but also changes the case of the other rows in the table for words that appear in the array. In other words, the case-changing code is not restricted to only the first row.

Any ideas on how to make this work?

Code is attached.

[Marrick13]

I found the solution to having the code select only the text in the first row of each table.
Add the following three lines right after the "Tbl.Rows(1).Range.Select" line:

Set sText = Selection.Cells(1).Range.Paragraphs(1).Range
sText.End = sText.Cells(1).Range.End - 1
sText.Select

The "sText.End = sText.Cells(1).Range.End - 1" line reduces the selection of the entire row to just the text in that row. Then the ".MoveEnd unit:=wdCharacter, Count:=-Len(sText) + 1" code in the True Title section works as though you manually selected the text in the first row.

[macropod]

Hi Marrick,

It's been a while since you last posted!

I think you'll find the following simpler, significantly more efficient and more comprehensive:

Public Sub FormatAllTables()
Application.ScreenUpdating = False
'Sets first row of each table as a repeating header and its style to "Title"
Dim Tbl As Word.Table
For Each Tbl In ActiveDocument.Tables
  With Tbl.Rows(1)
    .HeadingFormat = True
    .Range.Style = "title"
    .Range.Case = wdTitleWord
    Call TrueTitleCase(.Range)
  End With
  Tbl.Rows(2).Range.ParagraphFormat.SpaceBefore = 3
Next Tbl
Application.ScreenUpdating = True
End Sub
 
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")
Set RngTxt = Rng
With RngTxt
  For i = 1 To .Sentences.Count
    With .Sentences(i)
      If Len(.Text) > 2 And .Characters.Last = .Cells(1).Range.Characters.Last Then .End = .End - 1
      .MoveStart wdWord, 1
      If Len(.Text) > 0 Then
        For j = LBound(ArrTxt) To UBound(ArrTxt)
          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
            .Text = ArrTxt(j)
            .Replacement.Text = ""
            .Execute
          End With
          Do While .Find.Found = True
            If .InRange(Rng) Then
              .Text = LCase(.Text)
              .Collapse wdCollapseEnd
              .Find.Execute
            Else
              Exit Do
            End If
          Loop
        Next j
        While InStr(.Text, ":") > 0
          .MoveStartUntil ":", wdForward
          .Start = .Start + 1
          .MoveStartWhile " ", wdForward
          .Words.First.Case = wdTitleWord
        Wend
      End If
    End With
  Next i
End With
End Sub

[Marrick13]

Hello, Paul,

I haven't posted in a while not for lack of needing help but for trying to go it alone whenever I was trying to solve a coding problem. When I spend too much time without success, then I ask for help!

Thank you for your version, however, I get a runtime error 5941 (requested member of the collection does not exist) on:
"If Len(.Text) > 2 And .Characters.Last = .Cells(1).Range.Characters.Last Then .End = .End - 1"

I also noticed that with my original code, if any table had a first row that was blank, the code would apply the true title formatting to the words in its array to the text in the NEXT row of the same table. I was going to look into how to make sure it formats only the first row and ignores all tables with an empty first row when I got your response. I don't want it to do anything to any row but the first. Does your code handle this issue better than mine?

Are you testing the code in a Word document that has at least one table with two rows? The only way the error does not occur is if the document has no tables, and that is because if there are no tables, the FormatAllTables2 module won't call the TrueTitleCase module.

[macropod]

I am not getting that error at all. Can you attach a document to a post with the problem table? You do this via the paperclip symbol on the 'Go Advanced' tab.

[Marrick13]

File attached - your code is in the 'FormatAllTables2' module.

[macropod]

I'm not sure what the issue is, but try changing:

  For i = 1 To .Sentences.Count
    With .Sentences(i)
      If Len(.Text) > 2 And .Characters.Last = .Cells(1).Range.Characters.Last Then .End = .End - 1
      .MoveStart wdWord, 1

to:

  For i = 1 To .Cells.Count
    With .Cells(i).Range
      .Start = .Start + InStr(.Text, " ")
      .End = .End - 1

[Marrick13]

Paul,

It works GREAT now - thanks so much. It handles blank first rows and runs much faster than my jalopy of a code. I can also run it repeatedly on the same file - before, the other code seemed to have a problem with a lot of tables, so I was copying blocks of text to the template file, running the macro, then copying the formatted tables back to the main document.

I don't understand all of it, but it does just what I wanted. Thank you again.

[Marrick13]

I'm afraid I signed off on this too soon.

When I run the original True Title macro, which requires selecting the text to be formatted, it sets the case properly. As you can see in the attached ("True Title All Tables Test"), which includes the True Title code as well as the original code that applies it to all tables using the selection method, and your (Paul's) rewrite, the text in the first row of the first table is "Two Men on a Street Corner". This is the correct case, and is the result when I run the True Title macro as well as my original ("FormatAllTablesOrig").

Running our macro ("FormatAllTablesNew") produces "Two Men On a Street Corner" - the "On" is in proper case and should be lower case. The same sort of thing happens with the other four tables.

I chose the selection method only because it worked with the True Title code; your revised code doesn't use the selection method and I now see that it doesn't apply the True Title macro properly.

Any suggestiins?

[macropod]

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.

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.

[Marrick13]

Paul,

Thanks for the update and the Proper Case macro (I'll try that sometime). I was intending for the True Title macro only for single sentence and single line text in the first row of each table, but I appreciate he completeness of your efforts. However, now I'm seeing that if the first letter of the text is one of the array items, the revised macro makes it lower case. The original True Title code had a snippet that addressed this by detecting the first letter and applying upper case:

.MoveEnd Unit:=wdCharacter, Count:=-Len(sText) + 1
.Case = wdUpperCase

I've attached the test file with two examples in the first two tables, both of which begin with "A" but become "a" when the revised macro runs. Is this a simple fix? I don't want you spending much more time on this!

[macropod]

After:
.MoveStart wdCell, -1
Insert:
.End = .End - 1

[Marrick13]

I added that line and thought it worked, but you can see that it doesn't - in the attached test file, I've entered several tables with text in both rows. If you run your code ("FormatAllTablesNew"), you will see that the text in the second row that matches the array list gets lowercased, while this doesn't happen when you run my original code ("FormatAllTablesOrig"). All the new line you gave me seemed to do is slow it down (previous versions of your code ran much faster than mine). Therefore, I've been running it in a template file for a limited number of tables, then copying the formatted tables to the main document (which is almost 190 pages long).

I am okay with using my code; if you have a solution to this issue and it works in the attached, I'd be happy to test it again.

[macropod]

What a merry go-round this has been! Try:

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
      With .Duplicate
        For j = LBound(ArrTxt) To UBound(ArrTxt)
          With .Find
            'replace items in the list
            .ClearFormatting
            .Replacement.ClearFormatting
            .Forward = True
            .Wrap = wdFindStop
            .MatchWholeWord = True
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Format = False
            .Replacement.Text = ""
            .Text = ArrTxt(j)
            .Execute
          End With
          Do While .Find.Found
            If .InRange(Rng) Then
              .Text = LCase(ArrTxt(j))
              .Find.Execute
            Else
              Exit Do
            End If
          Loop
          .Start = RngTxt.Start
          .Collapse wdCollapseStart
        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

[Marrick13]

Paul,

Looks like you got it this time! Yes, it has been quite a merry go-round, and I appreciate your effort and help. Wouldn't have been able to do it without you!