Hi Jean,

And thanks that is working very very well in word 2003, but not in word
XP? I get an error

Run-time error '5834':
Item with specified name dose not exist.

it happens when it gets to .Style = StyleName (Ln 102)

This is all my code, I am very new to this, so I could be missing
somthing very simple?

Can you have a quick look? or will it only work in 2003.

Thanks again for the help!

Dim OfficialStyleList(100) As String

Sub HighlightUnofficialStyles()
   Dim oStyle As Style
   Dim nOfficialStyles As Integer ' last filled element of array
   Dim idx As Integer

   System.Cursor = wdCursorWait
   Application.ScreenUpdating = False

   nOfficialStyles = FillOfficialStyleList
   For Each oStyle In ActiveDocument.Styles
       If oStyle.InUse Then
           ' If oStyle.InUse = True, the style *may* be used
           ' somewhere in the document. It may also mean that
           ' the style was used at one time but isn't used now.

           For idx = 0 To nOfficialStyles
               If oStyle.NameLocal = OfficialStyleList(idx) Then
                   ' It's official, so stop looking
                   Exit For
               End If
           Next idx

           ' If we get here and the style wasn't in the
           ' official list, idx will be nOfficialStyles + 1
          If oStyle.NameLocal <> "Default Paragraph Font" _
And oStyle.NameLocal <> "No List" Then
If idx > nOfficialStyles Then
FindAndHighlight (oStyle.NameLocal)
End If
End If
       End If
   Next oStyle

   System.Cursor = wdCursorNormal
   Application.ScreenUpdating = True

End Sub

Private Function FillOfficialStyleList() As Integer
' This routine could be changed to read the list
' of names from a text file, which could be easily
' updated without needing to change the code.
   OfficialStyleList(0) = "Default Paragraph Font"
   OfficialStyleList(1) = "Ahead"
   OfficialStyleList(2) = "Bhead"
   OfficialStyleList(3) = "Chead"
   OfficialStyleList(4) = "Dhead"
   OfficialStyleList(5) = "MainText"
   OfficialStyleList(6) = "MainText1indent"
   OfficialStyleList(7) = "MainText2indent"
   OfficialStyleList(8) = "MainText3indent"
   OfficialStyleList(9) = "QuoteText"
   OfficialStyleList(10) = "TableHeader"
   OfficialStyleList(11) = "TableText"
   OfficialStyleList(12) = "bullet"
   OfficialStyleList(13) = "Bold"
   OfficialStyleList(14) = "BoldItalic"
   OfficialStyleList(15) = "BoldUnderItalic"
   OfficialStyleList(16) = "BoldUnderLine"
   OfficialStyleList(17) = "Underline"
   OfficialStyleList(18) = "UnderlineItalic"
   OfficialStyleList(19) = "MainTextNu"
   OfficialStyleList(20) = "image"
   OfficialStyleList(21) = "Footer"
   OfficialStyleList(22) = "Header"
   OfficialStyleList(23) = "highLight1indent"
   OfficialStyleList(24) = "highLightText"
   OfficialStyleList(25) = "StyleOff"
   OfficialStyleList(26) = "Hyperlink"
   FillOfficialStyleList = 26
End Function

Private Sub FindAndHighlight(StyleName As String)
' Thanks to Dave Rado, microsoft.public.word.docmanagement, 2001-08-29

   Dim oStory As Range
   Dim oSection As Section
   Dim oHeaderFooter As HeaderFooter
   Dim StyleFound As Boolean

   For Each oStory In ActiveDocument.StoryRanges
       Select Case oStory.StoryType
       '---------------
       'Do Headers and Footers separately because cycling thru _
       storyranges sometimes misses some Headers and Footers
       '---------------
       Case wdEvenPagesFooterStory, wdEvenPagesHeaderStory, _
           wdFirstPageFooterStory, wdFirstPageHeaderStory, _
           wdPrimaryFooterStory, wdPrimaryHeaderStory
       '---------------
       Case Else
           '---------------
           With oStory.Find
               .ClearFormatting
               .Replacement.ClearFormatting
               .Text = ""
               .Replacement.Text = ""
               .Format = True
               .Wrap = wdFindContinue
               .Style = StyleName
               .Replacement.Highlight = True
               If .Execute(Replace:=wdReplaceAll) Then
                   StyleFound = True
               '---------------
               Else
                   'if not found, search other stories of same type
                   '---------------
                   Do While Not oStory.NextStoryRange Is Nothing
                   '---------------
                       Set oStory = oStory.NextStoryRange
                       With oStory.Find
                           .ClearFormatting
                           .Replacement.ClearFormatting
                           .Text = ""
                           .Replacement.Text = ""
                           .Format = True
                           .Wrap = wdFindContinue
                           .Style = StyleName
                           .Replacement.Highlight = True
                           If .Execute(Replace:=wdReplaceAll) Then
                               StyleFound = True
                               Exit Do
                           End If
                       End With
                       '---------------
                   Loop
                   '---------------
               End If
               '---------------
           End With
           '---------------
       End Select
       '---------------
   Next oStory
   '---------------
   'If not found, check Headers and footers; unfortunately, this _
   method of cycling through them may convert any blank headers/ _
   footers into non-blankones, but at least it won't miss any out
   '---------------
   If Not StyleFound Then
       For Each oSection In ActiveDocument.Sections
           '---------------
           For Each oHeaderFooter In oSection.Headers
               '---------------
               If oHeaderFooter.Exists Then
                   '---------------
                   If Len(oHeaderFooter.Range.Text) > 1 Then
                       '---------------
                       With oHeaderFooter.Range.Find
                           .ClearFormatting
                           .Replacement.ClearFormatting
                           .Text = ""
                           .Replacement.Text = ""
                           .Format = True
                           .Wrap = wdFindContinue
                           .Style = StyleName
                           .Replacement.Highlight = True
                           '---------------
                           If .Execute(Replace:=wdReplaceAll) Then
                               StyleFound = True
                               Exit For
                           End If
                           '---------------
                       End With
                       '---------------
                   End If
                   '---------------
               End If
               '---------------
           Next oHeaderFooter
           For Each oHeaderFooter In oSection.Footers
               '---------------
               If oHeaderFooter.Exists Then
                   '---------------
                   If Len(oHeaderFooter.Range.Text) > 1 Then
                       '---------------
                       With oHeaderFooter.Range.Find
                           .ClearFormatting
                           .Replacement.ClearFormatting
                           .Text = ""
                           .Replacement.Text = ""
                           .Format = True
                           .Wrap = wdFindContinue
                           .Style = StyleName
                           .Replacement.Highlight = True
                           '---------------
                           If .Execute(Replace:=wdReplaceAll) Then
                               StyleFound = True
                               Exit For
                           End If
                           '---------------
                       End With
                       '---------------
                   End If
                   '---------------
               End If
               '---------------
           Next oHeaderFooter
           '---------------
       Next oSection
       '---------------
   End If
End Sub