Sub IndexForCat()
Dim myCharStyle As String
Dim myEntry As String
Dim myField As Field
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
  .Text = "><"
  .Replacement.Text = "> */-/* <"
  .Forward = True
  .Wrap = wdFindStop
  .Format = True
  .MatchCase = False
  .MatchWholeWord = False
  .MatchAllWordForms = False
  .MatchSoundsLike = False
  .MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Style = ActiveDocument.Styles("Big Yellow")
With Selection.Find
  .Text = "[\<]$I\[cat\]([0-9A-Za-z,\-\(\) ]{1,})\[([0-9A-Za-z,\-\(\) ]{1,})\][\>]"
  .Replacement.Text = " \1"
  .Forward = True
  .Wrap = wdFindStop
  .Format = True
  .MatchCase = False
  .MatchWholeWord = False
  .MatchAllWordForms = False
  .MatchSoundsLike = False
  .MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Style = ActiveDocument.Styles("Big Yellow")
With Selection.Find
  .Text = "[\<]$I)[cat\]([0-9A-Za-z,\-\(\) ]{1,})\[([0-9A-Za-z,\-\(\) ]{1,})\];([0-9A-Za-z,\-\(\) ]{1,})\[([0-9A-Za-z,\-\(\) ]{1,})\][\>]"
  .Replacement.Text = " \1:\3"
  .Forward = True
  .Wrap = wdFindStop
  .Format = True
  .MatchCase = False
  .MatchWholeWord = False
  .MatchAllWordForms = False
  .MatchSoundsLike = False
  .MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
myCharStyle = "Big Yellow"
Selection.HomeKey (wdStory)
With Selection.Find
  .ClearFormatting
  .Style = myCharStyle
  .Text = ""
  .Forward = True
  .Wrap = wdFindStop
  .Format = True
  .Replacement.Text = " "
End With
While Selection.Find.Execute
  myEntry = Selection.Text
  Selection.Collapse (wdCollapseEnd)
  Selection.Fields.Add _
  Range:=Selection.Range, _
  Type:=wdFieldIndexEntry, _
  Text:=Chr(34) & Trim(myEntry) & Chr(34) & " \f ""c"""
  Selection.Collapse (wdCollapseEnd)
Wend
Selection.EndKey Unit:=wdStory
Selection.TypeParagraph
Selection.Fields.Add _
Range:=Selection.Range, _
Type:=wdFieldIndex, _
Text:="\c ""1"" \z ""1031"" \f ""c"""
Selection.WholeStory
Selection.Fields.Update
Selection.Collapse (wdCollapseEnd)
ActiveWindow.View.ShowFieldCodes = False
Dim oRange As Range
Set oRange = Selection.Range
For Each Field In ActiveDocument.Fields
  For I = 0 To 8
    If Field.Type = wdFieldIndexEntry Then
      Field.Select
      Selection.MoveLeft Unit:=wdCharacter, Count:=1 '
      Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
      If Selection.Style = "Big Yellow" Then
        Selection.Range.Delete
      ElseIf Selection.Style = "Normal" Then
        I = 8
      End If
    End If
  Next I
Next Field
oRange.Select
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
  .Text = " */-/* "
  .Replacement.Text = ""
  .Forward = True
  .Wrap = wdFindContinue
  .Format = True
  .MatchCase = False
  .MatchWholeWord = False
  .MatchAllWordForms = False
  .MatchSoundsLike = False
  .MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("Big Yellow")
With Selection.Find
  .Text = " \* MERGEFORMAT"
  .Replacement.Text = ""
  .Forward = True
  .Wrap = wdFindContinue
  .Format = True
  .MatchCase = False
  .MatchWholeWord = False
  .MatchWildcards = False
  .MatchSoundsLike = False
  .MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub