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