Place words in a given font in index entries in a document at location of marked words-CodePudding

Goodevening everybody,

I made a VBA code which loops through all the words in a document and checks if the used font of that word is SimSun. If the font is SimSun, the word should be marked for the overall index. So I made this code:

Sub toevoegen()

Dim doc As Document

Set doc = ActiveDocument

For Each sentence In doc.StoryRanges
    For Each w In sentence.Words
        If w.Font.Name = "SimSun" Then
            doc.Indexes.MarkEntry Range:=Selection.Range, Entry:=w
        End If       
    Next   
Next
    
End Sub

The code works, but there is one problem. The index entries are placed at the end of the document. I want them to be placed after the words which where marked. So this is the result when you run the code:

And I want it to be after the word SimSun and Previous. I am stuck. Can somebody help me?

CodePudding user response：

It is putting the index entry at your selection point.

You can move the selection point.

Try:

Sub toevoegen()
  Dim doc As Document
  Set doc = ActiveDocument
  For Each sentence In doc.StoryRanges
    For Each w In sentence.Words
        If w.Font.Name = "SimSun" Then
            w.Select
            Selection.Collapse (wdCollapseEnd)
            doc.Indexes.MarkEntry Range:=Selection.Range, Entry:=w
        End If
    Next
  Next
End Sub

That will insert the index entry just after the target word. Running it multiple times will result in multiple entries for each word.

CodePudding user response：

Using Find/Replace is likely to be far quicker than looping through every 'sentence':

Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, StrIdx As String
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Format = False
    .Wrap = wdFindStop
    .Font.Name = "SimSun"
  End With
  Do While .Find.Execute
    StrIdx = .Text
    .Collapse wdCollapseEnd
    .Fields.Add .Duplicate, wdFieldEmpty, "XE " & StrIdx, False
    .MoveEndUntil Chr(21), wdForward
    .End = .End   1
    .Font.Reset
    If .Information(wdWithInTable) = True Then
      If .End = .Cells(1).Range.End - 1 Then
        .End = .Cells(1).Range.End
        .Collapse wdCollapseEnd
        If .Information(wdAtEndOfRowMarker) = True Then
          .End = .End   1
        End If
      End If
    End If
    If .End = ActiveDocument.Range.End Then Exit Do
    .Collapse wdCollapseEnd
  Loop
End With
Application.ScreenUpdating = True
End Sub