Count occurences of 2 words (that are near each other)

[petitfleur]

Hi all, I'm very new to VBA and to this forum. I'm wondering if there is a way to count the number of times that 2 specific words appear? As long as they are near each other, e.g. appearing within 10 characters of each other. Would appreciate any form of help or enlightenment for this. Thank you!

[macropod]

You could use a macro like:

Sub Demo()
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "<word1>?{1,10}<word2>"
    .Replacement.Text = ""
    .Forward = True
    .Format = False
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    i = i + 1
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
MsgBox i & " instances found."
End Sub

where 'word1' & 'word2' are the two words and the '1' & '10' in ?{1,10} represents the minimum and maximum intervening characters, respectively. Note that the test is case-sensitive, though there are ways around that and, as coded, only whole words are found, though there are ways around that, too.

[petitfleur]

Thank you so much Paul. May I know if this works regardless of the order the words appear? i.e. does it count the instances that word 2 appear before word 1 as well?

[macropod]

Hi petitfleur,

The code only finds the words in the order they're input.

[Guessed]

To resolve the order issue and allow the proximity to be measured in words rather characters the code needs to be hit the first word and then search backwards and forwards for the partner word.

Sub CountProx()
  Dim i As Integer, s1 As String, s2 As String, iWd As Long, aRng As Range, iProx As Integer
  Dim iWds As Long, iDocWordCount As Long, iStart As Long, iEnd As Long
  
  s1 = "word"
  s2 = "flash"
  iProx = 10
  
  Set aRng = ActiveDocument.Range
  iDocWordCount = ActiveDocument.Range.Words.Count
  
  With aRng.Find
    .ClearFormatting
    .Text = s1
    .Forward = True
    .MatchCase = False
    .MatchWholeWord = True
    .Wrap = wdFindStop
    .MatchWildcards = False
    .Execute
    Do While .Found
      iWd = ActiveDocument.Range(0, aRng.Start).Words.Count
      iStart = iWd - iProx
      If iStart < 1 Then iStart = 1
      iEnd = iWd + iProx
      If iEnd > iDocWordCount Then iEnd = iDocWordCount
      For i = iStart To iEnd
        If LCase(Trim(ActiveDocument.Words(i).Text)) = s2 Then
          iWds = iWds + 1
        End If
      Next i
      aRng.Collapse wdCollapseEnd
      .Execute
    Loop
  End With
  MsgBox "Pairs in Proximity: " & iWds

End Sub

[macropod]

Another way of automatically swapping the word order, sticking to the 'within characters' approach:

Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, j As Long, StrFnd As String
StrFnd = InputBox("Please input the Find paramenters, as:" & vbCr & _
  "word1|word2|x,y" & vbCr & _
  "where:" & vbCr & _
  "'x' is the minimum intervening character count and" & vbCr & _
  "'y' is the maximum intervening character count.")
For i = 1 To 2
  With ActiveDocument.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = "<" & Split(StrFnd, "|")(1 - i Mod 2) & ">?{" & Split(StrFnd, "|")(2) & "}<" & Split(StrFnd, "|")(2 - i) & ">"
      .Replacement.Text = ""
      .Forward = True
      .Format = False
      .Wrap = wdFindStop
      .MatchWildcards = True
      .Execute
    End With
    Do While .Find.Found
      j = j + 1
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
Next
Application.ScreenUpdating = True
MsgBox j & " instances found."
End Sub

[petitfleur]

This is really helpful. Thank you so much. However I got the following message when I run the code: "Runtime error 6". I'm not sure what I did wrongly.