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
|