Indexing Macro

mtames1 · #1 06-08-2011, 05:03 AM

I'm working on a macro to search for tagged text and replace it with an index marker. The tags look like this (<$I[cat]Surrealism;Ilse Aichinger[Aichinger. Ilse]>). I've created a macro to find similarly tagged text but I can't seem alter it to find these tags. Can you look at the macro and give me any suggestions?

Code:

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

macropod · #2 06-09-2011, 01:17 AM

Hi mtames1,

Perhaps you could explain what you're trying to achieve with the various kinds of tags. It appears you want to keep all except the '<$I[cat]' and '>' of some, but only a lesser portion of others. If all the tags are all in the format you've described, a single wildcard Find can locate them all. For example:
Find = \<$I\[cat\]([!\>]{1,})\>
Replace = \1

Also, your code has a lot of redundacy in it - there is no need to keep setting the Find/Replace parameters. For example:

Code:

...
Dim myField As Field
With Selection.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Forward = True
  .Wrap = wdFindStop
  .Format = True
  .MatchCase = False
  .MatchWholeWord = False
  .MatchAllWordForms = False
  .MatchSoundsLike = False
  .MatchWildcards = False
  .Text = "><"
  .Replacement.Text = "> */-/* <"
  .Execute Replace:=wdReplaceAll
  .Replacement.Style = ActiveDocument.Styles("Big Yellow")
  .Text = "[\<]$I\[cat\]([0-9A-Za-z,\-\(\) ]{1,})\[([0-9A-Za-z,\-\(\) ]{1,})\][\>]"
  .Replacement.Text = " \1"
  .Execute Replace:=wdReplaceAll
  .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"
  .Execute Replace:=wdReplaceAll
End With
myCharStyle = "Big Yellow"
...

PS: When posting code, please use code tags and formatted code.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Instant search not functional because of continuing "indexing"	arrigo	Outlook	1	12-07-2010 09:13 PM
Indexing in document	rafikul	Word	0	12-17-2009 11:07 PM