VBA для Word: использование массива для подсчета совпадений слов и фраз в тексте

Question

Я новичок в VBA и пытаюсь создать проект для работы.Мы нанимаем транскрипционистов на основе тестового файла, который они слушают и набирают.Я пытался написать макрос, который будет искать в тестах определенные ключевые слова (некоторые из которых используются в тесте несколько раз), а затем выдаст сообщение с результатами.Таким образом, мы можем оценить компетентность с первого взгляда.

Я собрал вместе прототип, но есть одна главная проблема: счетчик, кажется, не считает правильно.Я тестирую его на примере файла, содержащего все необходимые ключевые слова, но он зарегистрирует только половину из них.Я не уверен, в чем проблема, и был бы признателен за любую информацию.

Мой код приведен ниже, а скриншот полученного окна сообщения прилагается.

Sub WordCountTest()

    ' WordCountTest Macro

    'create definitions for search
    Dim wrd As range
    Dim var As Variant
    Dim searchlist()
    Dim numfound() As Integer
    Dim idx As Integer
    Dim strResults As String

    'necessary search terms
    searchlist = Array("Deposition Subpoena", "Amend Notice of Deposition", _
                       "fellowed", "corneal", "refractive", "LASIK", _
                       "1989", "Cedars-Sinai", "Capital", _
                       "January 28 2016", "technicians'", _
                       "topography", "OCT", "sclera", _
                       "limbus sclerocorneal", "fundoscopy", _
                       "Indirect ophthalmoscope", "diopter", _
                       "Keratometry", "Tomey", _
                       "Cirrus OCT tomographer", _
                       "No, not on the front", "ablation")

    'searching text
    ReDim numfound(0 To UBound(searchlist))
    For Each wrd In ActiveDocument.Words
        idx = 0
        For Each var In searchlist
            If Trim(wrd.Text) = searchlist(idx) Then
                numfound(idx) = numfound(idx) + 1
            End If
            idx = idx + 1
        Next var
    Next wrd

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

    MsgBox strResults

End Sub

---

Answer 1

вы можете хранить текст документа в строковой переменной и разбивать его на куски, разделенные вашими ключевыми словами:

Sub WordCountTest()

    ' WordCountTest Macro

    'create definitions for search
    Dim var As Variant
    Dim searchlist()
    Dim numfound() As Long
    Dim idx As Long
    Dim strResults As String

    'necessary search terms
    searchlist = Array("Deposition Subpoena", "Amend Notice of Deposition", _
                       "fellowed", "corneal", "refractive", "LASIK", _
                       "1989", "Cedars-Sinai", "Capital", _
                       "January 28 2016", "technicians'", _
                       "topography", "OCT", "sclera", _
                       "limbus sclerocorneal", "fundoscopy", _
                       "Indirect ophthalmoscope", "diopter", _
                       "Keratometry", "Tomey", _
                       "Cirrus OCT tomographer", _
                       "No, not on the front", "ablation")


    Dim docTxt As String
    docTxt = ActiveDocument.Content.Text

    Dim arr() As String
    ReDim numfound(0 To UBound(searchlist))

    For Each var In searchlist
        arr = Split(docTxt, var) ' divide document text in chuncks delimited by current var occurrences
        numfound(idx) = UBound(arr)
        idx = idx + 1
    Next var

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

    MsgBox strResults

End Sub

, но вы получите счетчик "OCT", который будет пересчитан дважды, так как найден как в "OCT", так и в"Томограф Cirrus OCT" (и тому подобное)

Answer 2

Вы также можете использовать встроенную функцию Find в Word для поиска каждого слова (Find.Execute во всем диапазоне, пока вы не найдете больше).Это работает довольно быстро (особенно если вы выключаете обновление экрана), и у вас есть другие варианты, такие как игнорирование регистра и использование корней / расширений слов или подстановочных знаков.

Я использовал этот метод в сочетании с формулой RegEx впоиск по шаблону для определения сокращений и определенных терминов.

Answer 3

Попробуйте:

Sub Demo()
Application.ScreenUpdating = False
Dim ArrFnd, strOut As String, i As Long, j As Long, k As Long
ArrFnd = Array("Deposition Subpoena", "Amend Notice of Deposition", _
  "fellowed", "corneal", "refractive", "LASIK", "1989", "Cedars-Sinai", _
  "Capital", "January 28 2016", "technicians'", "topography", "OCT", _
  "limbus sclerocorneal", "fundoscopy", "Indirect ophthalmoscope", _
  "sclera", "diopter", "Keratometry", "Tomey", "Cirrus OCT tomographer", _
  "No, not on the front", "ablation")
For i = 0 To UBound(ArrFnd)
  j = 0
  With ActiveDocument.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ArrFnd(i)
      .Replacement.Text = ""
      .Forward = True
      .Format = False
      .Wrap = wdFindStop
      .Execute
    End With
    Do While .Find.Found
      j = j + 1
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
  k = k + j
  strOut = strOut & vbCr & ArrFnd(i) & ": " & j
Next
Application.ScreenUpdating = True
MsgBox "Results -" & strOut & vbCr & vbCr & "TOTAL: " & k
End Sub

Answer 4

Код работает идеально только для слов.Это не удастся для подсчета фраз.Так как я также рассматриваю код как впечатляюще чистый кусок кода, как прокомментировал Marcucciboy2, я попытался сохранить основной подход в уже написанном коде.Вы можете попытаться добавить несколько строк

'At the beginning 
Dim wrd2 as range
Dim st,En as long 

'then at For Each var In searchlist
    For Each var In searchlist
            Set wrd2 = wrd
            If InStr(1, searchlist(idx), " ") > 0 Then
            st = wrd.Start
            En = st + Len(searchlist(idx))
            If En > ActiveDocument.Content.StoryLength Then En = ActiveDocument.Content.StoryLength
            Set wrd2 = ActiveDocument.Range(st, En)
            End If

            If Trim(wrd2.Text) = searchlist(idx) Then
                numfound(idx) = numfound(idx) + 1
            End If
            idx = idx + 1
        Next var

Однако, поскольку он используется для поиска "тестового файла, который они прослушивают и вводят" , подумайте о возможностях

1.В случае вводимых слов может не совпадать с регистром поиска.

2. Фразы могут содержать несколько пробелов между словами.