Microsoft Office Forums - View Single Post - Create document index looking for certain formatted text

leaning · 08-28-2017, 08:58 PM

All,

I found this!
I have a lot of red-boldeds, so it gives the "not responding" message while it is running, so I'd like to add a status indicator, but otherwise, it builds the list, then you click in wherever in your document you want the index to start, References> Insert Index, and POW! Instant Index. I'll have to change the font to smaller and to save paper and flipping through pages, make it so it's 3-4 columns instead of 2, but as it is, it works great! So, unless anyone has anything to improve on this, I'm good. Thanks, Allen Wyatt!

https://wordribbon.tips.net/T010438_..._an_Index.html

Code:

Sub InsertingIndexEntries()
    Application.ScreenUpdating = False

    'Go to the first page of the document
    Selection.HomeKey wdStory, wdMove

    'Set up the Find and Replace operation
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWildcards = False
        .Font.Bold = True
        .Font.ColorIndex = wdRed ' I added this so it looks for red text
    End With

    'Finds the bold text and inserts an index entry.
    Do
        Selection.Find.Execute
        If Selection.Find.Found Then
            'Checks if the Index field was selected
            'This occurs if it does not contain any entries
            If UCase(Selection.Range.Text) <> "NO INDEX ENTRIES FOUND." Then
                'Insert an index entry and use the text within
                'the selected range as the entry name
                ActiveDocument.Indexes.MarkEntry _
                  Range:=Selection.Range, _
                  Entry:=Selection.Range.Text, _
                  EntryAutoText:=Selection.Range.Text, _
                  CrossReference:="", _
                  CrossReferenceAutoText:="", _
                  BookmarkName:="", _
                  Bold:=False, _
                  Italic:=False, _
                  Reading:=""
                'Move past text that was found and the new index entry
                Selection.MoveRight wdCharacter, 1, wdExtend
                Selection.Collapse wdCollapseEnd
            End If
        End If
    Loop While Selection.Find.Found

    Application.ScreenUpdating = True
    Application.ScreenRefresh
    MsgBox "Done"
End Sub