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
