VBA IF Statement Help

Shelley Lou · #1 03-13-2024, 02:06 PM

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

gmaxey · #2 03-13-2024, 11:44 PM

Can you show what your 1.8 is supposed to look like?

Shelley Lou · #3 03-14-2024, 07:35 AM

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

gmaxey · #4 03-14-2024, 11:27 AM

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

Shelley Lou · #5 03-15-2024, 08:06 AM

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

gmaxey · #6 03-15-2024, 08:54 AM

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.

Shelley Lou · #7 03-15-2024, 09:58 AM

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.

gmaxey · #8 03-15-2024, 12:33 PM

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

Shelley Lou · #9 03-15-2024, 03:28 PM

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

gmaxey · #10 03-15-2024, 04:18 PM

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

Shelley Lou · #11 03-17-2024, 04:20 AM

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

gmaxey · #12 03-17-2024, 05:25 AM

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 ....

Shelley Lou · #13 03-17-2024, 10:16 AM

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,}"

but doesn't capture if there are further cross references separated by the words 'and', 'or', 'and/or' or a comma, e.g. clause 1 and 1.1 or clause 1, 2 or 2.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.

gmaxey · #14 03-18-2024, 06:35 AM

Difficult to follow without a "small" sample of text showing what you are trying to process and what your desired result is.

Shelley Lou · #15 03-18-2024, 09:30 AM

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

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