Найти, выделить и перечислить количество экземпляров слов, найденных в документе, используя VBA - PullRequest
Новая
       36

Найти, выделить и перечислить количество экземпляров слов, найденных в документе, используя VBA

0 голосов
/ 21 февраля 2020

У меня есть список ключевых слов, которые мне нужно искать в документах Word.

Я создал скрипт, который выполняет поиск в документе и выделяет все найденные экземпляры, в том числе соответствующие всем формам слова (т. Е. Исправляют, исправляют, крепления). После обработки появляется окно сообщения, которое должно суммировать количество найденных экземпляров для каждого слова.

Проблема в том, что, хотя подпрограмма выделения позволяет использовать все формы слова (.MatchAllWordForms = True), я пропущено что-то для подсчета, так что подсчитываются только точные совпадения.

Можете ли вы помочь мне обновить это так, чтобы все слова и словоформы были выделены и суммированы в окне сообщения? 

'
    ' Highlight Macro

    Sub HighlightKeywords()


    Dim range As range
    Dim i As Long
    Dim Keywords

    ' put list of terms to find here

    Keywords = Array("wrong", "broke", "fix", "swap", "missing", "mistake", "revert", "oops", "backwards", "shatter", "drop")

    For i = 0 To UBound(Keywords)

    Set range = ActiveDocument.range

    With range.Find
    .Text = Keywords(i)
    .Format = True
    .MatchCase = True
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = True

    Do While .Execute(Forward:=True) = True
    range.HighlightColorIndex = wdYellow

    Loop

    End With

    Next

    ReDim numfound(0 To UBound(Keywords))

        For Each wrd In ActiveDocument.Words
            idx = 0
            For Each var In Keywords
                If Trim(wrd.Text) = Keywords(idx) Then
                    numfound(idx) = numfound(idx) + 1
                End If
                idx = idx + 1
            Next var
        Next wrd

        idx = 0
        For Each var In Keywords
            strResults = strResults & Keywords(idx) & " : " & _
                         numfound(idx) & vbCr
            idx = idx + 1
        Next var

        MsgBox strResults


    End Sub

1 Ответ

0 голосов
/ 21 февраля 2020

Окно сообщения имеет очень ограниченную выходную емкость. Если вы действительно хотите go по этому пути, попробуйте: 

Sub HighlightKeywords()
Application.ScreenUpdating = False
Dim i As Long, j As Long, Keywords, StrOut As String
' put list of terms to find here
Keywords = Array("wrong", "broke", "fix", "swap", "missing", "mistake", "revert", "oops", "backwards", "shatter", "drop")
For i = 0 To UBound(Keywords)
  j = 0
  With ActiveDocument.Range
    With .Find
      .Text = Keywords(i)
      .Format = False
      .MatchCase = True
      .MatchAllWordForms = True
      .MatchWildcards = False
      .Forward = True
      .Wrap = wdFindStop
      .Execute
    End With
    Do While .Find.Found = True
      j = j + 1
      .Duplicate.HighlightColorIndex = wdYellow
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
  StrOut = StrOut & vbCr & Keywords(i) & ": " & j
Next
Application.ScreenUpdating = True
MsgBox "Found the following:" & StrOut
End Sub
...