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