#1
|
|||
|
|||
Macro that formats (true title) case by Heading style
I have a macro I adapted from an online source that applies "true title" case to all text with a "Heading 1" style. It works wonderfully provided that Heading 1 text is not the last text in the document. The code is in test document attached - if you run the code, you'll see that it goes into an infinite loop. But if you add text after the Heading-styled text, it runs properly (although I just noticed that it produces a "code execution" error on the end select line after it finishes). The more puzzling issue is why it goes into the infinite loop if Heading 1 text is the last text. I tried a few "Loop Untils" but they didn't stop the endless looping. The wend has something to do with this but I can't figure it out. Can someone help?
|
#2
|
||||
|
||||
The following code shouldn't loop
Code:
Sub Apply_True_Title_Case_by_Style() Dim oRng As Range Dim oPara As Paragraph Dim StyleName As String Dim vFindText As Variant Dim vReplText As Variant Dim wrd As Integer StyleName = "Heading 1" vFindText = Array("A", "An", "And", "As", "At", "But", "By", "For", _ "If", "In", "Of", "On", "Or", "The", "To", "With") vReplText = Array("a", "an", "and", "as", "at", "but", "by", "for", _ "if", "in", "of", "on", "or", "the", "to", "with") For Each oPara In ActiveDocument.Paragraphs If oPara.Style = StyleName Then Set oRng = oPara.Range oRng.Case = wdTitleWord With oRng.Find For wrd = LBound(vFindText) To UBound(vFindText) .Text = vFindText(wrd) .Replacement.Text = vReplText(wrd) .Execute MatchCase:=True, Replace:=wdReplaceAll Next wrd End With End If Next oPara End Sub
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#3
|
||||
|
||||
Try:
Code:
Sub Apply_True_Title_Case_by_Style() Application.ScreenUpdating = False Dim StyleName As String, wrd As Long, Count As Long Const lclist As String = " a an and as at but by for from if in is of " _ & " on or the this to " StyleName = "Heading 1" With ActiveDocument With .Range With .Find .ClearFormatting .Wrap = wdFindStop .Forward = True .Format = True .MatchWildcards = False .Text = "" .Style = ActiveDocument.Styles(StyleName) .Execute End With Do While .Find.Found = True Count = Count + 1 With .Duplicate .Case = wdTitleWord For wrd = 2 To .ComputeStatistics(wdStatisticWords) If InStr(lclist, " " & LCase(Trim(.Words(wrd))) & " ") > 0 Then _ .Words(wrd).Case = wdLowerCase Next wrd End With If .End = ActiveDocument.Range.End Then Exit Sub .Collapse Direction:=wdCollapseEnd .Find.Execute Loop End With End With Select Case Count Case 0 MsgBox "Macro could not find any instances of '" & StyleName & "'.", vbOKOnly, "Results" Case 1 MsgBox "Macro applied true title case to 1 instance of '" & StyleName & "'.", vbOKOnly, "Results" Case Is > 1 MsgBox "Macro applied true title case to " & Count & " instances of '" & StyleName & "'.", vbOKOnly, "Results" End Select Application.ScreenUpdating = True End Sub
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] Last edited by macropod; 09-19-2015 at 06:47 PM. Reason: Code revision |
#4
|
|||
|
|||
Greg,
Thanks very much - I had the previous version of your true title code (that required selecting the text) but was unable to adapt it for formatting all instances of a style. This version works great! Macropod, I just tested your code and it has the same problem I encountered: the macro goes into an infinite loop if the last text in the document has the 'Heading 1' style, but doesn't if there is text after it (that either has no style or a style OTHER than Heading 1). That's okay, though - Greg's macro works splendidly. Thank you both for your help - I really appreciate it. |
#5
|
||||
|
||||
Quote:
If .End = ActiveDocument.Range.End Then Exit Sub before: .Collapse Direction:=wdCollapseEnd
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#6
|
|||
|
|||
Yes, that works. Brilliant, Macropod - thank you!
|
#7
|
|||
|
|||
Marrick,
I love it when I get credit for Graham's work The reason for your continuous loop is because you can't collapse the selection to the right side of the end of document mark. That means if the last paragraph has Heading 1 applied you are constantly processing the last paragraph (end of document mark). Here is my version: Code:
Sub Greg_Apply_True_Title_Case_by_Style() Dim oPar As Paragraph Dim oRng As Range Dim arrFind() As String Dim lngIndex As Long arrFind = Split("A,An,And,As,At,But,By,For,If,In,Of,On,Or,The,To,With", ",") For Each oPar In ActiveDocument.Paragraphs If oPar.Style = "Heading 1" Then Set oRng = oPar.Range oRng.Case = wdTitleWord With oRng.Find For lngIndex = 0 To UBound(arrFind) .Text = arrFind(lngIndex) .Replacement.Text = LCase(.Text) .MatchWholeWord = True .Execute MatchCase:=True, Replace:=wdReplaceAll Next lngIndex End With End If Next oPar End Sub |
#8
|
||||
|
||||
My code's far & away the fastest, though. On a 214-page document with 302 headings to process:
Graham's code took : 118 seconds Greg's code took: 66 seconds My code took: 4 seconds Turning off screen updating for Graham's code & Greg's code (mine already had it), gave: Graham's code took : 95 seconds Greg's code took: 42 seconds My code took: 4 seconds
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#9
|
|||
|
|||
Greg,
Sorry for "crediting" you with Graham's code; I must have gotten my "GM's" mixed up (didn't check my sources first!). But competition is good, despite what John D. Rockefeller claimed. Macropod, thank you. You are correct - your code runs MUCH faster than Greg's. I timed them on a 50-page document with 60 headings, and yours took 237 seconds with screen updating off, and 298 seconds with it on; Paul's ran in 1.5 seconds with updating on and 1.3 seconds with it off. Since they both produce the same results, I'd call that a "no contest". I've added some counters and attached Paul's version for the record. Thanks, guys, for all your help! |
#10
|
|||
|
|||
Marrick,
Next time if it is a completion, I'll try harder ;-). If you are going to adapt the time saving methods incorporated by Paul then don't crap it up with another loop through the paragraphs. Try: Code:
Option Explicit Sub Apply_True_Title_Case_by_Style() Const strLCList As String = " a an and as at but by for from if in is of on or the this to " Dim strStyleName As String Dim oRng As Range Dim lngIndex As Long, lngStyleCount As Long strStyleName = "Heading 1" Set oRng = ActiveDocument.Range With oRng.Find .ClearFormatting .Wrap = wdFindStop .Forward = True .Format = True .MatchWildcards = False .Text = "" .Style = ActiveDocument.Styles(strStyleName) Do While .Execute lngStyleCount = lngStyleCount + 1 If oRng.End = ActiveDocument.Range.End Then Exit Do oRng.Collapse wdCollapseEnd Loop End With Select Case lngStyleCount Case 0: MsgBox "There are no occurrences of "" & strStyleName & "" style in this document.", _ vbInformation + vbOKOnly, "Style Count" Exit Sub Case 1 If MsgBox("There is 1 occurrence of " & Chr(34) + strStyleName + Chr(34) & " style in this document." & vbCr & vbCr _ & "Do you want to apply true title case to it?", vbQuestion + vbYesNo, "Style Count") = vbNo Then Exit Sub End If Case Else If MsgBox("There are " & lngStyleCount & " occurrences of " & Chr(34) + strStyleName + Chr(34) & _ " style in this document." & vbCr & vbCr _ & "Do you want to apply true title case to them?", vbQuestion + vbYesNo, "Style Count") = vbNo Then Exit Sub End If End Select Application.ScreenUpdating = False Set oRng = ActiveDocument.Range With oRng With .Find .ClearFormatting .Wrap = wdFindStop .Forward = True .Format = True .MatchWildcards = False .Text = "" .Style = ActiveDocument.Styles(strStyleName) End With Do While .Find.Execute With .Duplicate .Case = wdTitleWord For lngIndex = 2 To .ComputeStatistics(wdStatisticWords) If InStr(strLCList, " " & LCase(Trim(.Words(lngIndex))) & " ") > 0 Then .Words(lngIndex).Case = wdLowerCase End If Next lngIndex End With If .End = ActiveDocument.Range.End Then Exit Do .Collapse Direction:=wdCollapseEnd Loop End With Application.ScreenUpdating = True Select Case lngStyleCount Case 1 MsgBox "Macro applied true title case to 1 instance of " & Chr(34) & strStyleName & Chr(34) & ".", vbOKOnly, "Results" Case Is > 1 MsgBox "Macro applied true title case to " & lngStyleCount & " instances of " & Chr(34) & strStyleName & Chr(34) & ".", vbOKOnly, "Results" End Select lbl_Exit: Exit Sub End Sub |
#11
|
|||
|
|||
I see your point, Greg, although I'm not VBA-fluent enough to have seen the difference. I just wanted a pre-count and the paragraph loop code was already written, so I grabbed it. But why is his code so much faster? You never know how big a document is going to be and if it takes minutes to achieve the same results that can be had in seconds, why not strive for that kind of speed?
By the way, thanks for the rewrite. |
#12
|
|||
|
|||
Marrick,
The method Graham and I used looped through each element of an array and searched for each element of that array in the Heading 1 text. Apparently that process simply takes more time than looping though a simple count and evaluating InStr. It is hardly noticeable with one or two heading but certainly apparent in large documents as Paul demonstrated. He is usually pretty good at seeing those efficiencies and school all of us here. |
#13
|
|||
|
|||
VBA has a way of moving like greased lightning when the iterations are few but grinding down when they are many. So it's always good to test with large files.
Thanks to all three of you for assisting and educating me - I couldn't have done it without you! |
#14
|
||||
|
||||
Sometimes ... I'm still learning from you guys too
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
Tags |
loop style format case |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Tab character causes style change to Heading 4 after macro | Jennifer Murphy | Word VBA | 2 | 12-14-2015 02:31 AM |
Macro to create a title in the Header when a certain text style is used (such as Heading 1) | Lonesy | Word VBA | 1 | 06-03-2015 03:57 AM |
Customising a style that uses Title Case formatting | Madanjeet | Word | 6 | 05-18-2015 10:11 AM |
True Title Case for First Row of All Tables | Marrick13 | Word VBA | 14 | 12-11-2013 09:12 PM |
Macro to replace one specific heading style with another | ubns | Word VBA | 44 | 09-04-2012 08:17 PM |