#1
|
|||
|
|||
VBA IF Statement Help
I have created a macro to help me when formatting documents. The code finds instances of rogue punctuation, mostly ones that are bold and highlights them bright green so I can easily identify what I need to reformat in line with housestyle. I've got the code to also not highlight bold punctuation if contained within a bold heading or part of a bold definition through the IF Statement.
I'm struggling of what to add to the IF Statement to capture other instances e.g. more than one bold punctuation together (see 1.8 of the attached document where I've listed a few examples). Would appreciate any advice. Bold Punc but not within Bold Text.docx Code:
Sub HighlightBoldPuncDemo1() Application.ScreenUpdating = False Dim oRng As Range Set oRng = ActiveDocument.Range With oRng.Find .ClearFormatting .Replacement.ClearFormatting .Replacement.Highlight = True 'Activate replacement highlighting .Forward = True .Wrap = wdFindStop .Format = False .MatchWildcards = True Options.DefaultHighlightColorIndex = wdBrightGreen .text = Chr(34) 'Highlight non-bold straight quotes .Font.Bold = False .Execute Replace:=wdReplaceAll .text = "[[\]^0145^0146^0147^0148]{1,}" 'Highlight non bold curly quotes/apostrophes/square brackets .Execute Replace:=wdReplaceAll .text = "[" & Chr(44) & Chr(145) & Chr(146) & Chr(147) & Chr(148) & "\(\)\[\]\:\;\.\'\,]" 'Highlight bold curly quotes/apostrophes, brackets/square brackets, comma etc. .Font.Bold = True .Execute Replace:=wdReplaceAll End With With oRng.Find .text = "[" & Chr(34) & "\(\)\[\]\:\;\.\'\,]" 'highlight bold straight quotes if word is plain text but don't highlight if all bold .Font.Bold = True While .Execute oRng.Select On Error Resume Next If oRng.Characters.Last.Next.Font.Bold = False Then oRng.HighlightColorIndex = wdBrightGreen 'highlight if bold but not within a heading or definition If oRng.Characters.Last.Previous.Font.Bold = True Then oRng.HighlightColorIndex = wdNoHighlight 'don't highlight if contained within a bold heading Wend End With End Sub |
#2
|
|||
|
|||
Can you show what your 1.8 is supposed to look like?
|
#3
|
|||
|
|||
VBA IF Statement Help
Hi Greg, thank you so much for responding. I have added a 1.9 to the document of what the code should be highlighting but isn't - hope that helps.
Bold Punc but not within Bold Text.docx Capture.JPG |
#4
|
|||
|
|||
I think this will get you close:
Sub MarkPunct() Application.ScreenUpdating = False Dim oRng As Range Set oRng = ActiveDocument.Range With oRng.Find .ClearFormatting .Replacement.ClearFormatting .Replacement.Highlight = True 'Activate replacement highlighting .Forward = True .Wrap = wdFindStop .Format = False .MatchWildcards = True Options.DefaultHighlightColorIndex = wdPink .Text = Chr(34) & "*" & Chr(34) While .Execute If oRng.Characters(2).Font.Bold = False Then oRng.Characters(1).HighlightColorIndex = wdPink If oRng.Characters.Last.Previous.Font.Bold = False Then oRng.Characters.Last.HighlightColorIndex = wdPink If oRng.Characters.First.Font.Bold = False And oRng.Characters(2).Font.Bold = True Then oRng.Characters.First.HighlightColorIndex = wdPink If oRng.Characters.Last.Font.Bold = False And oRng.Characters.Last.Previous.Font.Bold = True Then oRng.Characters.Last.HighlightColorIndex = wdPink Wend End With Set oRng = ActiveDocument.Range With oRng.Find .Text = "[" & Chr(145) & Chr(146) & Chr(147) & Chr(148) & "]" .MatchWildcards = True .Replacement.Highlight = True .Font.Bold = False .Execute Replace:=wdReplaceAll End With Set oRng = ActiveDocument.Range With oRng.Find .Text = "[" & Chr(44) & Chr(145) & Chr(146) & Chr(147) & Chr(148) & "\(\)\[\]\:\;\.\'\,]" .MatchWildcards = True .Replacement.Highlight = True .Font.Bold = True .Execute Replace:=wdReplaceAll End With Set oRng = ActiveDocument.Range With oRng.Find .Text = "[" & Chr(39) & Chr(146) & "]" 'Highlight bold curly quotes/apostrophes, brackets/square brackets, comma etc. .MatchWildcards = True .Font.Bold = True While .Execute If oRng.Characters.First.Previous.Font.Bold And oRng.Characters.Last.Next.Font.Bold Then oRng.HighlightColorIndex = wdNoHighlight End If Wend End With End Sub Last edited by gmaxey; 03-15-2024 at 08:01 AM. |
#5
|
|||
|
|||
VBA IF Statement Help
Hi Greg, thank you so much for the updated code, I really appreciate it, everything is working as it should except it still highlights any bold punctuation in bold headings but I think I can live with that, otherwise it might get a bit too complicated.
My code in Post 1 was taken from a larger macro which was working ok, albeit a bit slow as I may be missing a loop or two. I've tried adding your updated code in place of my previous code but I am now getting an Error 5941 in another part of the code which I wasn't before. I've tried inserting the updated code in various places but still getting the Error but when I remove the updated code, it works again. I'm a bit confused as to what may be causing the error. I've colour coded the code with Blue Text for your updated code and Red Text for the Error. test document for highlight.DOCX Code:
Sub Test_HouseStyleHighlight_Demo2() Application.ScreenUpdating = False 'highlights body of doc and footnotes Dim StrFnd As String, i As Long, Rng As Range, ArrFnd, ArrFndB, oPara As Paragraph Dim StrFndA As String, StrFndB As String StrFndA = "[Aa]rticle,[Aa]ppendix,[Cc]lause,[Pp]aragraph,[Pp]art,[Ss]chedule" 'highlight numbers after these words StrFndB = "[Mm]inute,[Hh]our,[Dd]ay,[Ww]eek,[Mm]onth,[Yy]ear,[Ww]orking,[Bb]usiness" 'highlight numbers before these words With ActiveDocument.Range.Find .ClearFormatting .text = "^w^p" .Replacement.text = "^p" .Execute Replace:=wdReplaceAll .text = "^p^w" 'Delete white spaces after paragraph breaks .Replacement.text = "^&" .Execute Replace:=wdReplaceAll End With For Each Rng In ActiveDocument.StoryRanges With Rng Select Case .StoryType Case wdMainTextStory, wdFootnotesStory For i = 0 To UBound(Split(StrFndA, ",")) With .Duplicate With .Find .ClearFormatting .Replacement.ClearFormatting .Forward = True .Wrap = wdFindStop .MatchWildcards = True .text = Split(StrFndA, ",")(i) & "[s ^s]@[0-9.]{1,}" 'Highlight manual cross refs End With Do While .Find.Execute .MoveStart wdWord, 1 .HighlightColorIndex = wdBrightGreen .Collapse wdCollapseEnd Loop End With Next For i = 0 To UBound(Split(StrFndB, ",")) With .Duplicate With .Find .ClearFormatting .Replacement.ClearFormatting .Forward = True .Wrap = wdFindStop .MatchWildcards = True .text = "<[0-9][ ^s]" & Split(StrFndB, ",")(i) 'Highlight digits below 10 End With Do While .Find.Execute .MoveEnd wdWord, -1 .End = .End - 1 .HighlightColorIndex = wdBrightGreen .Collapse wdCollapseEnd Loop End With Next With Rng.Find .ClearFormatting .Replacement.ClearFormatting .Replacement.Highlight = True 'Activate replacement highlighting .Forward = True .Wrap = wdFindStop .Format = False .MatchWildcards = True Options.DefaultHighlightColorIndex = wdBrightGreen .text = Chr(34) & "*" & Chr(34) 'Highlight non bold straight quotes While .Execute If Rng.Characters(2).Font.Bold = False Then Rng.Characters(1).HighlightColorIndex = wdBrightGreen If Rng.Characters.Last.Previous.Font.Bold = False Then Rng.Characters.Last.HighlightColorIndex = wdBrightGreen Wend End With Set Rng = ActiveDocument.Range With Rng.Find .text = Chr(34) 'Highlight non-bold straight quotes .MatchWildcards = True .Replacement.Highlight = True .Font.Bold = False .Execute Replace:=wdReplaceAll End With With Rng.Find .text = "[" & Chr(145) & Chr(146) & Chr(147) & Chr(148) & "]" 'Apostrophies and double quotes .MatchWildcards = True .Replacement.Highlight = True .Font.Bold = False .Execute Replace:=wdReplaceAll End With Set Rng = ActiveDocument.Range With Rng.Find .text = "[" & Chr(44) & Chr(145) & Chr(146) & Chr(147) & Chr(148) & "\(\)\[\]\:\;\.\'\,]" .MatchWildcards = True .Replacement.Highlight = True .Font.Bold = True .Execute Replace:=wdReplaceAll End With Set Rng = ActiveDocument.Range With Rng.Find .text = "[" & Chr(39) & Chr(146) & "]" 'Highlight bold curly quotes/apostrophes, brackets/square brackets, comma etc. .MatchWildcards = True .Font.Bold = True While .Execute If Rng.Characters.First.Previous.Font.Bold And Rng.Characters.Last.Next.Font.Bold Then Rng.HighlightColorIndex = wdNoHighlight End If Wend End With With Rng.Find .ClearFormatting .Replacement.ClearFormatting .Forward = True .Wrap = wdFindStop .MatchCase = True .Wrap = wdFindContinue .MatchWholeWord = True .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Replacement.Highlight = True 'Activate replacement highlighting Options.DefaultHighlightColorIndex = wdBrightGreen 'Highlight key house style words to check case StrFnd = "PROVIDED,PROVIDED THAT,PROVIDED ALWAYS,PROVIDED FURTHER,Provided That,Provided Always,Provided Further,Provided that,Provided further,Provided Further That, " & _ "Means,Appendix,Annexure,Appendices,Clause,Paragraph,Part,Schedule,Section,Article,Company Number,Company number,Title Number,Registered Number,Registration Number,Registered Office" For i = 0 To UBound(Split(StrFnd, ",")) .MatchCase = True .text = Split(StrFnd, ",")(i) .Execute Replace:=wdReplaceAll .text = Split(StrFnd, ",")(i) & "s" .Execute Replace:=wdReplaceAll Next StrFnd = "sub-clause,sub clause,subclause,sub Clause,sub-paragraph,sub paragraph,subparagraph,per cent,percent,percentage,per centum,percentum,chapter,percentage points" For i = 0 To UBound(Split(StrFnd, ",")) .MatchCase = False .text = Split(StrFnd, ",")(i) .Execute Replace:=wdReplaceAll .text = Split(StrFnd, ",")(i) & "s" .Execute Replace:=wdReplaceAll Next StrFnd = "ten,eleven,twelve,thirteen,fourteen,fifteen,sixteen,seventeen,eighteen,nineteen,twenty,twenty one,twenty four,thirty,forty,forty eight,fifty,sixty,seventy,eighty,ninety," & _ "tenth,eleventh,twelfth,thirteenth,fourteenth,fifteenth,sixteenth,seventeenth,eighteenth,nineteenth,twentieth" For i = 0 To UBound(Split(StrFnd, ",")) 'Highlight figures written as words & subclauses etc. .MatchCase = False .text = Split(StrFnd, ",")(i) .Execute Replace:=wdReplaceAll .text = Split(StrFnd, ",")(i) & "s" .Execute Replace:=wdReplaceAll Next Options.DefaultHighlightColorIndex = wdNoHighlight 'Words NOT to highlight StrFnd = "Common Part,Common Parts,Permitted Part,Permitted Parts,Structural Part,Schedule of Condition,Schedules of Dilapidations,Schedule of Dilapidations,CDM Regulations," & _ "CIL Regulations,Schedule to the Town,Retained Parts,Reserved Parts" For i = 0 To UBound(Split(StrFnd, ",")) .MatchCase = True .text = Split(StrFnd, ",")(i) .Execute Replace:=wdReplaceAll .text = Split(StrFnd, ",")(i) & "s" .Execute Replace:=wdReplaceAll Next .MatchWildcards = True 'Activate wildcards Options.DefaultHighlightColorIndex = wdBrightGreen .text = "([0-9]@{1,}.[0-9]{1,})" 'Highlight manual cross refs separated by period 1.1 .Replacement.text = "" .Execute Replace:=wdReplaceAll .text = "([0-9]@{1,}.[0-9]{1,}.[0-9]{1,})" 'Highlight manual cross refs separated by period 1.1.1 .Replacement.text = "" .Execute Replace:=wdReplaceAll .text = "([0-9]@{1,}.[0-9]{1,}.[0-9]{1,}.[0-9]{1,})" 'Highlight manual cross refs separated by period 1.1.1.1 .Replacement.text = "" .Execute Replace:=wdReplaceAll .text = "LR[0-9]{1,2}" 'Highlight Prescribed Clause cross refs LR1-14 .Font.Bold = False .Execute Replace:=wdReplaceAll .text = "([.\?\!]) ([A-Z])" 'Highlight spaces after full stops,question marks and exclamation marks? .Execute Replace:=wdReplaceAll .text = "[£\$\€][0-9]@.[0-9]{1,}" 'Highlight pounds with .00 .Execute Replace:=wdReplaceAll .text = "[£\$\€][0-9]@,[0-9]{1,}.[0-9]{1,}" 'Highlight pounds with .00 .Execute Replace:=wdReplaceAll .text = "([0-9]{1,}[dhnrst]{2})" 'Highlight ordinal numbers .Execute Replace:=wdReplaceAll .text = "([^t\ \^s][[\(][A-Za-z0-9]{1,3}[\)\]][,\]\)\^t\ \^s])(*)" 'Highlight letters/digits within brackets in same paragraph re new sublevels/manual numbering .Execute Replace:=wdReplaceAll .text = "<[ap].[m.]{1,2}" 'Highlight times .Execute Replace:=wdReplaceAll .text = "<[AP].[M.]{1,2}" .Execute Replace:=wdReplaceAll .text = "[ ]([\)\]\\-\,\'\:\;\.\?\!)])" 'Highlight spaces before punctuation .Font.Bold = False .Execute Replace:=wdReplaceAll .text = "" 'Highlight superscript that are not bold .Replacement.text = "" .Font.Bold = False .Font.Superscript = True .Execute Replace:=wdReplaceAll For Each oPara In ActiveDocument.Paragraphs 'Highlights missing punctuation at end of paragraphs With oPara.Range If .Information(wdWithInTable) Or .Font.AllCaps Or .Characters.First.Font.Bold Or Len(.text) < 3 Then GoTo NextFor Else If Not .Characters.Last.Previous Like "*[.!?:;,]" Then If Not .Characters.Last.Previous.Fields(1).Result = "]" Then If Not .Characters.Last.Previous Like "]" Then .Words.Last.Previous.Words(1).HighlightColorIndex = wdPink End If End If End If Select Case .Words.Last.Previous.Words(1) Case "and", "but", "or", "then", "plus", "minus", "less", "nor" Set Rng = .Words.Last '.Previous.Words(1) Rng.MoveStartUntil cSet:=" " & Chr(160), count:=-10 Set Rng = Rng.Characters.First.Previous.Previous If Rng.text = ";" Then 'if oPara ends with these words and have semi-colon before them do nothing no highlight else .Words.Last.Previous.Words(1).HighlightColorIndex = wdNoHighlight If Rng.text = "," Then 'if oPara ends with these words and have semi-colon before them do nothing no highlight else .Words.Last.Previous.Words(1).HighlightColorIndex = wdPink End If End If Case Else End Select End If End With NextFor: Next Options.DefaultHighlightColorIndex = wdNoHighlight 'Don't highlight anything already in fields eg cross refs and square brackets ActiveWindow.View.ShowFieldCodes = True .ClearFormatting .MatchWildcards = False .text = "^d" .Execute Replace:=wdReplaceAll ActiveWindow.View.ShowFieldCodes = False End With Case Else End Select End With Next Rng Application.ScreenUpdating = True MsgBox "Complete" Selection.HomeKey Unit:=wdStory End Sub Last edited by Shelley Lou; 03-15-2024 at 08:21 AM. Reason: Adding test document |
#6
|
|||
|
|||
Shelley,
If you pull that loop out and run it on your test document, you will see where and why the error occurs: Code:
Sub A() Dim oPara As Paragraph Dim Rng As Range On Error GoTo Err_Handler: For Each oPara In ActiveDocument.Paragraphs 'Highlights missing punctuation at end of paragraphs With oPara.Range If .Information(wdWithInTable) Or .Font.AllCaps Or .Characters.First.Font.Bold Or Len(.Text) < 3 Then GoTo NextFor Else If Not .Characters.Last.Previous Like "*[.!?:;,]" Then If Not .Characters.Last.Previous.Fields(1).Result = "]" Then If Not .Characters.Last.Previous Like "]" Then .Words.Last.Previous.Words(1).HighlightColorIndex = wdPink End If End If End If Select Case .Words.Last.Previous.Words(1) Case "and", "but", "or", "then", "plus", "minus", "less", "nor" Set Rng = .Words.Last '.Previous.Words(1) Rng.MoveStartUntil cSet:=" " & Chr(160), Count:=-10 Set Rng = Rng.Characters.First.Previous.Previous If Rng.Text = ";" Then 'if oPara ends with these words and have semi-colon before them do nothing no highlight else .Words.Last.Previous.Words(1).HighlightColorIndex = wdNoHighlight If Rng.Text = "," Then 'if oPara ends with these words and have semi-colon before them do nothing no highlight else .Words.Last.Previous.Words(1).HighlightColorIndex = wdPink End If End If Case Else End Select End If End With NextFor: Next lbl_Exit: Exit Sub Err_Handler: MsgBox Err.Number & " - " & Err.Description oPara.Range.Select Resume End Sub There is no field(1) in the range. |
#7
|
|||
|
|||
VBA IF Statement Help
Hi Greg, oh crikey I'm confused now as I thought it was working ok before. I thought I'd got the code to not highlight paragraphs that end with a closing square bracket which may be in the form of a text form field or just plain text square brackets when looking for missing punctuation at the end of paragraphs. Is that not how the code is written? I want the code to miss those paragraphs - I'm not sure how else to write the code.
|
#8
|
|||
|
|||
Your error occurs because you are trying to evaluate a field code in paragraph 1.3 and that field does not exist in paragraph 1.3
Revised code. Only evaluate field if field is present. Code:
Sub A() Dim oPara As Paragraph Dim Rng As Range On Error GoTo Err_Handler: For Each oPara In ActiveDocument.Paragraphs 'Highlights missing punctuation at end of paragraphs With oPara.Range If .Information(wdWithInTable) Or .Font.AllCaps Or .Characters.First.Font.Bold Or Len(.Text) < 3 Then GoTo NextFor Else If Not .Characters.Last.Previous Like "*[.!?:;,]" Then Select Case True Case .Characters.Last.Previous.Fields.Count = 1 If Not .Characters.Last.Previous.Fields(1).Result = "]" Then .Words.Last.Previous.Words(1).HighlightColorIndex = wdPink End If Case Else If Not .Characters.Last.Previous Like "]" Then .Words.Last.Previous.Words(1).HighlightColorIndex = wdPink End If End Select End If Select Case .Words.Last.Previous.Words(1) Case "and", "but", "or", "then", "plus", "minus", "less", "nor" Set Rng = .Words.Last '.Previous.Words(1) Rng.MoveStartUntil cSet:=" " & Chr(160), Count:=-10 Set Rng = Rng.Characters.First.Previous.Previous If Rng.Text = ";" Then 'if oPara ends with these words and have semi-colon before them do nothing no highlight else .Words.Last.Previous.Words(1).HighlightColorIndex = wdNoHighlight If Rng.Text = "," Then 'if oPara ends with these words and have semi-colon before them do nothing no highlight else .Words.Last.Previous.Words(1).HighlightColorIndex = wdPink End If End If Case Else End Select End If End With NextFor: Next oPara lbl_Exit: Exit Sub Err_Handler: MsgBox Err.Number & " - " & Err.Description oPara.Range.Select Resume End Sub |
#9
|
|||
|
|||
VBA IF Statement Help
Hi Greg, I've added the new lines of code to my macro you have provided. If I leave the Err Handler bit in it makes all my auto cross refs highlighted when they shouldn't be, but when I comment them out its throwing up an Error 5825 Object has been deleted. I have marked the line of code red in the below code. The last bit of the code is supposed to leave any auto cross refs/fields unchanged and only highlight the manual ones. Any idea why this might be happening?
Code:
'On Error GoTo Err_Handler: For Each oPara In ActiveDocument.Paragraphs 'Highlights missing punctuation at end of paragraphs With oPara.Range If .Information(wdWithInTable) Or .Font.AllCaps Or .Characters.First.Font.Bold Or Len(.text) < 3 Then GoTo NextFor Else If Not .Characters.Last.Previous Like "*[.!?:;,]" Then Select Case True Case .Characters.Last.Previous.Fields.count = 1 If Not .Characters.Last.Previous.Fields(1).Result = "]" Then .Words.Last.Previous.Words(1).HighlightColorIndex = wdBrightGreen End If Case Else If Not .Characters.Last.Previous Like "]" Then .Words.Last.Previous.Words(1).HighlightColorIndex = wdBrightGreen End If End Select End If Select Case .Words.Last.Previous.Words(1) Case "and", "but", "or", "then", "plus", "minus", "less", "nor" Set Rng = .Words.Last '.Previous.Words(1) Rng.MoveStartUntil cSet:=" " & Chr(160), count:=-10 Set Rng = Rng.Characters.First.Previous.Previous If Rng.text = ";" Then 'if oPara ends with these words and have semi-colon before them do nothing no highlight else .Words.Last.Previous.Words(1).HighlightColorIndex = wdNoHighlight If Rng.text = "," Then 'if oPara ends with these words and have semi-colon before them do nothing no highlight else .Words.Last.Previous.Words(1).HighlightColorIndex = wdPink End If End If Case Else End Select End If End With NextFor: Next 'lbl_Exit: 'Exit Sub 'Err_Handler: 'MsgBox Err.Number & " - " & Err.Description ' oPara.Range.Select 'Resume Options.DefaultHighlightColorIndex = wdNoHighlight 'Don't highlight anything already in fields eg cross refs and square brackets ActiveWindow.View.ShowFieldCodes = True .ClearFormatting .MatchWildcards = False .text = "^d" .Execute Replace:=wdReplaceAll ActiveWindow.View.ShowFieldCodes = False End With Case Else End Select End With Next Rng |
#10
|
|||
|
|||
Shelley,
Until now, I have made no effort to make your complete code run, only to try to show you why would were getting an error. Here is your complete code and it runs start to finish on your test document without error. Not sure if it does everything you want or not. Code:
Sub Test_HouseStyleHighlight_Demo2() Application.ScreenUpdating = False 'highlights body of doc and footnotes Dim StrFnd As String, i As Long, Rng As Range, ArrFnd, ArrFndB, oPara As Paragraph Dim StrFndA As String, StrFndB As String StrFndA = "[Aa]rticle,[Aa]ppendix,[Cc]lause,[Pp]aragraph,[Pp]art,[Ss]chedule" 'highlight numbers after these words StrFndB = "[Mm]inute,[Hh]our,[Dd]ay,[Ww]eek,[Mm]onth,[Yy]ear,[Ww]orking,[Bb]usiness" 'highlight numbers before these words With ActiveDocument.Range.Find .ClearFormatting .Text = "^w^p" .Replacement.Text = "^p" .Execute Replace:=wdReplaceAll .Text = "^p^w" 'Delete white spaces after paragraph breaks .Replacement.Text = "^&" .Execute Replace:=wdReplaceAll End With For Each Rng In ActiveDocument.StoryRanges With Rng Select Case .StoryType Case wdMainTextStory, wdFootnotesStory For i = 0 To UBound(Split(StrFndA, ",")) With .Duplicate With .Find .ClearFormatting .Replacement.ClearFormatting .Forward = True .Wrap = wdFindStop .MatchWildcards = True .Text = Split(StrFndA, ",")(i) & "[s ^s]@[0-9.]{1,}" 'Highlight manual cross refs End With Do While .Find.Execute .MoveStart wdWord, 1 .HighlightColorIndex = wdBrightGreen .Collapse wdCollapseEnd Loop End With Next For i = 0 To UBound(Split(StrFndB, ",")) With .Duplicate With .Find .ClearFormatting .Replacement.ClearFormatting .Forward = True .Wrap = wdFindStop .MatchWildcards = True .Text = "<[0-9][ ^s]" & Split(StrFndB, ",")(i) 'Highlight digits below 10 End With Do While .Find.Execute .MoveEnd wdWord, -1 .End = .End - 1 .HighlightColorIndex = wdBrightGreen .Collapse wdCollapseEnd Loop End With Next With Rng.Find .ClearFormatting .Replacement.ClearFormatting .Replacement.Highlight = True 'Activate replacement highlighting .Forward = True .Wrap = wdFindStop .Format = False .MatchWildcards = True Options.DefaultHighlightColorIndex = wdBrightGreen .Text = Chr(34) & "*" & Chr(34) 'Highlight non bold straight quotes While .Execute If Rng.Characters(2).Font.Bold = False Then Rng.Characters(1).HighlightColorIndex = wdBrightGreen If Rng.Characters.Last.Previous.Font.Bold = False Then Rng.Characters.Last.HighlightColorIndex = wdBrightGreen Wend End With Set Rng = ActiveDocument.Range With Rng.Find .Text = Chr(34) 'Highlight non-bold straight quotes .MatchWildcards = True .Replacement.Highlight = True .Font.Bold = False .Execute Replace:=wdReplaceAll End With With Rng.Find .Text = "[" & Chr(145) & Chr(146) & Chr(147) & Chr(148) & "]" 'Apostrophies and double quotes .MatchWildcards = True .Replacement.Highlight = True .Font.Bold = False .Execute Replace:=wdReplaceAll End With Set Rng = ActiveDocument.Range With Rng.Find .Text = "[" & Chr(44) & Chr(145) & Chr(146) & Chr(147) & Chr(148) & "\(\)\[\]\:\;\.\'\,]" .MatchWildcards = True .Replacement.Highlight = True .Font.Bold = True .Execute Replace:=wdReplaceAll End With Set Rng = ActiveDocument.Range With Rng.Find .Text = "[" & Chr(39) & Chr(146) & "]" 'Highlight bold curly quotes/apostrophes, brackets/square brackets, comma etc. .MatchWildcards = True .Font.Bold = True While .Execute If Rng.Characters.First.Previous.Font.Bold And Rng.Characters.Last.Next.Font.Bold Then Rng.HighlightColorIndex = wdNoHighlight End If Wend End With With Rng.Find .ClearFormatting .Replacement.ClearFormatting .Forward = True .Wrap = wdFindStop .MatchCase = True .Wrap = wdFindContinue .MatchWholeWord = True .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Replacement.Highlight = True 'Activate replacement highlighting Options.DefaultHighlightColorIndex = wdBrightGreen 'Highlight key house style words to check case StrFnd = "PROVIDED,PROVIDED THAT,PROVIDED ALWAYS,PROVIDED FURTHER,Provided That,Provided Always,Provided Further,Provided that,Provided further,Provided Further That, " & _ "Means,Appendix,Annexure,Appendices,Clause,Paragraph,Part,Schedule,Section,Article,Company Number,Company number,Title Number,Registered Number,Registration Number,Registered Office" For i = 0 To UBound(Split(StrFnd, ",")) .MatchCase = True .Text = Split(StrFnd, ",")(i) .Execute Replace:=wdReplaceAll .Text = Split(StrFnd, ",")(i) & "s" .Execute Replace:=wdReplaceAll Next StrFnd = "sub-clause,sub clause,subclause,sub Clause,sub-paragraph,sub paragraph,subparagraph,per cent,percent,percentage,per centum,percentum,chapter,percentage points" For i = 0 To UBound(Split(StrFnd, ",")) .MatchCase = False .Text = Split(StrFnd, ",")(i) .Execute Replace:=wdReplaceAll .Text = Split(StrFnd, ",")(i) & "s" .Execute Replace:=wdReplaceAll Next StrFnd = "ten,eleven,twelve,thirteen,fourteen,fifteen,sixteen,seventeen,eighteen,nineteen,twenty,twenty one,twenty four,thirty,forty,forty eight,fifty,sixty,seventy,eighty,ninety," & _ "tenth,eleventh,twelfth,thirteenth,fourteenth,fifteenth,sixteenth,seventeenth,eighteenth,nineteenth,twentieth" For i = 0 To UBound(Split(StrFnd, ",")) 'Highlight figures written as words & subclauses etc. .MatchCase = False .Text = Split(StrFnd, ",")(i) .Execute Replace:=wdReplaceAll .Text = Split(StrFnd, ",")(i) & "s" .Execute Replace:=wdReplaceAll Next Options.DefaultHighlightColorIndex = wdNoHighlight 'Words NOT to highlight StrFnd = "Common Part,Common Parts,Permitted Part,Permitted Parts,Structural Part,Schedule of Condition,Schedules of Dilapidations,Schedule of Dilapidations,CDM Regulations," & _ "CIL Regulations,Schedule to the Town,Retained Parts,Reserved Parts" For i = 0 To UBound(Split(StrFnd, ",")) .MatchCase = True .Text = Split(StrFnd, ",")(i) .Execute Replace:=wdReplaceAll .Text = Split(StrFnd, ",")(i) & "s" .Execute Replace:=wdReplaceAll Next .MatchWildcards = True 'Activate wildcards Options.DefaultHighlightColorIndex = wdBrightGreen .Text = "([0-9]@{1,}.[0-9]{1,})" 'Highlight manual cross refs separated by period 1.1 .Replacement.Text = "" .Execute Replace:=wdReplaceAll .Text = "([0-9]@{1,}.[0-9]{1,}.[0-9]{1,})" 'Highlight manual cross refs separated by period 1.1.1 .Replacement.Text = "" .Execute Replace:=wdReplaceAll .Text = "([0-9]@{1,}.[0-9]{1,}.[0-9]{1,}.[0-9]{1,})" 'Highlight manual cross refs separated by period 1.1.1.1 .Replacement.Text = "" .Execute Replace:=wdReplaceAll .Text = "LR[0-9]{1,2}" 'Highlight Prescribed Clause cross refs LR1-14 .Font.Bold = False .Execute Replace:=wdReplaceAll .Text = "([.\?\!]) ([A-Z])" 'Highlight spaces after full stops,question marks and exclamation marks? .Execute Replace:=wdReplaceAll .Text = "[£\$\€][0-9]@.[0-9]{1,}" 'Highlight pounds with .00 .Execute Replace:=wdReplaceAll .Text = "[£\$\€][0-9]@,[0-9]{1,}.[0-9]{1,}" 'Highlight pounds with .00 .Execute Replace:=wdReplaceAll .Text = "([0-9]{1,}[dhnrst]{2})" 'Highlight ordinal numbers .Execute Replace:=wdReplaceAll .Text = "([^t\ \^s][[\(][A-Za-z0-9]{1,3}[\)\]][,\]\)\^t\ \^s])(*)" 'Highlight letters/digits within brackets in same paragraph re new sublevels/manual numbering .Execute Replace:=wdReplaceAll .Text = "<[ap].[m.]{1,2}" 'Highlight times .Execute Replace:=wdReplaceAll .Text = "<[AP].[M.]{1,2}" .Execute Replace:=wdReplaceAll .Text = "[ ]([\)\]\\-\,\'\:\;\.\?\!)])" 'Highlight spaces before punctuation .Font.Bold = False .Execute Replace:=wdReplaceAll .Text = "" 'Highlight superscript that are not bold .Replacement.Text = "" .Font.Bold = False .Font.Superscript = True .Execute Replace:=wdReplaceAll Options.DefaultHighlightColorIndex = wdNoHighlight 'Don't highlight anything already in fields eg cross refs and square brackets ActiveWindow.View.ShowFieldCodes = True .ClearFormatting .MatchWildcards = False .Text = "^d" .Execute Replace:=wdReplaceAll ActiveWindow.View.ShowFieldCodes = False End With Case Else End Select End With Next Rng For Each oPara In ActiveDocument.Paragraphs 'Highlights missing punctuation at end of paragraphs With oPara.Range If .Information(wdWithInTable) Or .Font.AllCaps Or .Characters.First.Font.Bold Or Len(.Text) < 3 Then GoTo NextFor Else If Not .Characters.Last.Previous Like "*[.!?:;,]" Then Select Case True Case .Characters.Last.Previous.Fields.Count = 1 If Not .Characters.Last.Previous.Fields(1).Result = "]" Then .Words.Last.Previous.Words(1).HighlightColorIndex = wdPink End If Case Else If Not .Characters.Last.Previous Like "]" Then .Words.Last.Previous.Words(1).HighlightColorIndex = wdPink End If End Select End If Select Case .Words.Last.Previous.Words(1) Case "and", "but", "or", "then", "plus", "minus", "less", "nor" Set Rng = .Words.Last '.Previous.Words(1) Rng.MoveStartUntil cSet:=" " & Chr(160), Count:=-10 Set Rng = Rng.Characters.First.Previous.Previous If Rng.Text = ";" Then 'if oPara ends with these words and have semi-colon before them do nothing no highlight else .Words.Last.Previous.Words(1).HighlightColorIndex = wdNoHighlight If Rng.Text = "," Then 'if oPara ends with these words and have semi-colon before them do nothing no highlight else .Words.Last.Previous.Words(1).HighlightColorIndex = wdPink End If End If Case Else End Select End If End With NextFor: Next Application.ScreenUpdating = True MsgBox "Complete" Selection.HomeKey Unit:=wdStory lbl_Exit: Exit Sub Err_Handler: MsgBox Err.Number & " - " & Err.Description End Sub |
#11
|
|||
|
|||
VBA IF Statement Help
Hi Greg, thank you so much for your time and patience and updating the code for me, I really do appreciate your help - this has been a labour of love and a work in progress for me for a couple of years now as I am always finding new things to either add or improve. I use the code every day to help me format documents into housestyle much more efficiently so thank you. Best wishes, Shelley
|
#12
|
|||
|
|||
You are welcome Shelley. Yes, it does look like a running effort. There are things yo could do to streamline the code a bit, but if its not broke ....
|
#13
|
|||
|
|||
VBA IF Statement Help
Hi Greg, I would very much welcome any thoughts or observations you have on how I can improve/streamline the code further, as any help would be very much appreciated.
The next part of the code I am trying to update is how manual cross references are highlighted. For example, this line of code only highlights the cross reference immediately after the string words: Code:
.text = Split(StrFndA, ",")(i) & "[s ^s]@[0-9.]{1,}" I've been testing in a separate macro but haven't got anything working as of yet with my IF Statement, so its still a work in progress at the moment. |
#14
|
|||
|
|||
Difficult to follow without a "small" sample of text showing what you are trying to process and what your desired result is.
|
#15
|
|||
|
|||
VBA IF Statement Help
Hi Greg, the attached are examples of clauses references that appear in documents when I am housestyling. Does this help - I think I have captured most of the instances I come across when formatting documents.
Highlight clause references.docx Last edited by Shelley Lou; 03-18-2024 at 09:57 AM. Reason: Replacing attachment |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
IF Statement (again) | teza2k06 | Excel | 8 | 02-11-2022 08:41 AM |
Converting a Select statement in Excel to an update statement | shabbaranks | Excel Programming | 5 | 10-31-2018 11:47 PM |
Need a little help with an if statement | cangelis | Excel | 2 | 04-08-2015 05:55 PM |
If statement, may be? | Tony Singh | Excel | 6 | 03-04-2015 12:52 PM |
Need help with If, Then Statement Please | cangelis | Excel | 4 | 01-03-2014 09:10 AM |