Word VBA: recursive word search and work count - vba

Question

I am trying to create a Word macro VBA to do the following:
for the active Word document
find the name “Bob” and count how many times “this is new” is associated to Bob (recursion search and count)
For example. Bob = 2, Matthew = 1, Mark = 0
Report – JP
PQR – Bob, Mark
· Some text
Report – SH
JKL – Bob, Mark
· Some text
GHI – Bob
· This is new.
· More text
Report – JM
MNO – Bob, Mark
· Some text
DEF – Bob
· This is new.
· More text
ABC – Matthew
· This is new.
· More text
Report – BB
PQR – Bob, Mark
· Some text
I believe that my attempt using this code is not correct. Any help?
sResponse = "is new"
iCount = 0
Application.ScreenUpdating = False
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Text = sResponse
' Loop until Word can no longer
' find the search string and
' count each instance
Do While .Execute
iCount = iCount + 1
Selection.MoveRight
Loop
End With
MsgBox sResponse & " appears " & iCount & " times

Answer 1

For example:
Sub Demo()
Application.ScreenUpdating = False
Dim StrNm As String, StrOut As String, i As Long
StrOut = "Bob = 0, " & _
"Matthew = 0, " & _
"Mark = 0, "
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "<[! ]# · This is new"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
End With
Do While .Find.Execute
If .Text = "" Then Exit Do
StrNm = Split(.Text, " ")(0)
If InStr(StrOut, StrNm) > 0 Then
i = Split(Split(StrOut, StrNm & " = ")(1), ", ")(0)
StrOut = Replace(StrOut, StrNm & " = " & i, StrNm & " = " & i + 1)
Else
StrOut = StrOut & StrNm & " = " & 1 & ", "
End If
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
MsgBox "Frequency Report:" & StrOut
End Sub
If you've missed any names with 'This is new', the code above will simply add them to the pre-defined StrOut list.

Answer 2

A part of your stated original problem was that you wanted to list ALL of the names, including names that NEVER show up as lines with the phrase "This is new". So the code must build a Dictionary of names and keep track of each name and its count as all the lines are scanned. (See this site for good information on dictionaries.)
There are a couple of "gotchas" in the ultimate solution, including allowing for names with accented characters (e.g. José) and names with spaces (e.g. "Bob Smith"). So I created a special "trim" function to scan each name and make sure the string is really just the name.
Assumptions:
Lines that DO NOT begin with "Report" are the lines that have names
The words separated by commas after the dash character are the names
The list of names ends when you find the special "separator" character
Here is the example code:
Option Explicit
Sub CountPhrase()
'--- define the dash and separator characters/strings - may be special codes
Dim dash As String
Dim separator As String
Dim phrase As String
dash = "–" 'this is not a keyboard dash
separator = "·" 'this is not a keyboard period
phrase = "This is new"
Dim nameCount As Scripting.Dictionary
Set nameCount = New Scripting.Dictionary
Dim i As Long
For i = 1 To ThisDocument.Sentences.Count
'--- locate the beginning of the names lines (that DO NOT have start with "Report")
If Not (ThisDocument.Sentences(i) Like "Report*") Then
'--- pick out the names for this report
Dim dashPosition As Long
Dim separatorPosition As Long
dashPosition = InStr(1, ThisDocument.Sentences(i), dash, vbTextCompare)
separatorPosition = InStr(1, ThisDocument.Sentences(i), separator, vbTextCompare)
Dim names() As String
names = Split(Mid$(ThisDocument.Sentences(i), _
dashPosition + 1, _
separatorPosition - dashPosition), ",")
'--- now check if the phrase exists in this sentence or not
Dim phrasePosition As Long
phrasePosition = InStr(1, ThisDocument.Sentences(i), phrase, vbTextCompare)
'--- add names to the dictionary if they don't exist, and increment
' the name count if the phrase exists in this sentence
Dim name As Variant
For Each name In names
Dim thisName As String
thisName = SpecialTrim$(name)
If Len(thisName) > 0 Then
If nameCount.Exists(thisName) Then
If phrasePosition > 0 Then
nameCount(thisName) = nameCount(thisName) + 1
End If
Else
If phrasePosition > 0 Then
nameCount.Add thisName, 1
Else
nameCount.Add thisName, 0
End If
End If
End If
Next name
End If
Next i
'--- show your work
Dim popUpMsg As String
popUpMsg = "Frequency Report:"
For Each name In nameCount.Keys
popUpMsg = popUpMsg & vbCrLf & name & _
": count = " & nameCount(name)
Next name
MsgBox popUpMsg, vbInformation + vbOKOnly
End Sub
Function SpecialTrim(ByVal inString As String) As String
'--- this function can be tricky, because you have to allow
' for characters with accents and you must allow for names
' with spaces (e.g., "Bob Smith")
'--- trim from the left until the first allowable letter
Dim keepString As String
Dim thisLetter As String
Dim i As Long
For i = 1 To Len(inString)
thisLetter = Mid$(inString, i, 1)
If LetterIsAllowed(thisLetter) Then
Exit For
End If
Next i
'-- special case: if ALL of the letters are not allowed, return
' an empty string
If i = Len(inString) Then
SpecialTrim = vbNullString
Exit Function
End If
'--- now transfer allowable characters to the keeper
' we're done when we reach the first unallowable letter (or the end)
For i = i To Len(inString)
thisLetter = Mid$(inString, i, 1)
If LetterIsAllowed(thisLetter) Then
keepString = keepString & thisLetter
Else
Exit For
End If
Next i
SpecialTrim = Trim$(keepString)
End Function
Function LetterIsAllowed(ByVal inString As String) As Boolean
'--- inString is expected to be a single character
' NOTE: a space " " is allowed in the middle, so the caller must
' Trim the returned string
Const LETTERS = " abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" & _
"àáâãäåçèéêëìíîïðñòóôõöùúûüýÿŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝ"
Dim i As Long
For i = 1 To Len(LETTERS)
If inString = Mid$(LETTERS, i, 1) Then
LetterIsAllowed = True
Exit Function
End If
Next i
LetterIsAllowed = False
End Function