Count specific words and return the value

[Suzanne]

I'd like to count the number of specified words, e.g., "that" and "which" in
my document and put the number of times it appears in the section in a table
cell.

Thanks

 

[Helmut Weber]

Hi Suzanne,

like that:

Sub Test445B()
Dim rTmp As Range
Set rTmp = ActiveDocument.Sections(1).Range
With ActiveDocument.Tables(1)
.Cell(1, 1).Range.Text = "The"
.Cell(2, 1).Range.Text = "quick"
.Cell(3, 1).Range.Text = "brown"
.Cell(4, 1).Range.Text = "fox"
.Cell(1, 2).Range.Text = UBound(Split(rTmp.Text, "The"))
.Cell(2, 2).Range.Text = UBound(Split(rTmp.Text, "quick"))
.Cell(3, 2).Range.Text = UBound(Split(rTmp.Text, "brown"))
.Cell(4, 2).Range.Text = UBound(Split(rTmp.Text, "fox"))
End With
End Sub

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

 

[Russ]

Hi Helmut,
I like it.
It's fast.
To help ignore case you could add something like the change I made below for
the word "the"

Sub Test445B()
Dim rTmp As Range
Set rTmp = ActiveDocument.Sections(1).Range
With ActiveDocument.Tables(1)
.Cell(1, 1).Range.Text = "The or the"
.Cell(2, 1).Range.Text = "quick"
.Cell(3, 1).Range.Text = "brown"
.Cell(4, 1).Range.Text = "fox"
.Cell(1, 2).Range.Text = UBound(Split(LCase(rTmp.Text), "the"))
.Cell(2, 2).Range.Text = UBound(Split(rTmp.Text, "quick"))
.Cell(3, 2).Range.Text = UBound(Split(rTmp.Text, "brown"))
.Cell(4, 2).Range.Text = UBound(Split(rTmp.Text, "fox"))
End With
End Sub

 

[Russ]

Helmut,
I see that split has third optional argument for case or caseless search.
Use vbTextCompare or vbBinaryCompare for types of search result.


Sub Test445B()
Dim rTmp As Range
Set rTmp = ActiveDocument.Sections(1).Range
With ActiveDocument.Tables(1)
.Cell(1, 1).Range.Text = "The"
.Cell(2, 1).Range.Text = "quick"
.Cell(3, 1).Range.Text = "brown"
.Cell(4, 1).Range.Text = "fox"
.Cell(1, 2).Range.Text = UBound(Split(rTmp.Text, "The", vbTextCompare))
.Cell(2, 2).Range.Text = UBound(Split(rTmp.Text, "quick"))
.Cell(3, 2).Range.Text = UBound(Split(rTmp.Text, "brown"))
.Cell(4, 2).Range.Text = UBound(Split(rTmp.Text, "fox"))
End With
End Sub

 

[Helmut Weber]

Hi Russ,

I only wanted to give a hint,
how it could be done if the text is very simple,
remembering recent discussions on counting words.

Of course the code is not flexible enough
for serious work.

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

 

[Greg Maxey]

The various inputbox UI makes this rather crude and better suited for a
UserForm but I adapted some code that Doug Robbins has provided from time to
time to count and report unique words. I simply added the feature to
"exclude" words from processing or "designate" specific words to process
only.

Sub WordFrequency2()
Dim aWord As Range 'Raw word pulled from doc
Dim SingleWord As String 'Processed raw word
Dim Words() As String 'Array to hold unique words
Dim Freq() As Integer 'Frequency counter for Unique Words
Dim Ans As String 'Logic router
Dim WordNum As Integer 'Number of unique words
Dim ByFreq As Boolean 'Flag for sorting order
Dim Count As Long 'Total words in the document
Dim Excludes As String 'Words to be excluded
Dim Specifics As String 'Specific words to process
Dim bSpecifics As Boolean 'Logic router
Dim Found As Boolean 'Temporary flag
Dim j, k, l, Temp As Integer 'Temporary variables
Dim lngProcessedWords As Long 'Total processed words in document
Dim NonWordObjects As Long
Dim TotalWords As Long
Dim tword As String '
Dim tmpName
Dim oRng As Word.Range
Dim oTbl As Word.Table

Excludes = InputBox$("Enter words that you wish to exclude. " _
& "Place each word within square brackets [ ]. " _
& "Example: [is][a].", "Excluded Words", "")
If Len(Excludes) = 0 Then
Specifics = InputBox("Enter any specific words you wish to process. " _
& "Place each word withing squiggly brackets { }. " _
& "Example: {I}{me}{you}.", "Specific Words", "")
If Len(Specifics) > 0 Then bSpecifics = True
End If
'Find out how to sort
ByFreq = True
Ans = InputBox$("Default sort order is word freqeuncy." _
& " To sort alphabetically by word, type Word in the field below.",
"Sort order", "FREQ")
If Ans = "" Then End
If UCase(Ans) = "WORD" Then
ByFreq = False
End If
System.Cursor = wdCursorWait
WordNum = 0
Count = ActiveDocument.Words.Count
ReDim Words(Count)
ReDim Freq(Count)
'Control the repeat
For Each aWord In ActiveDocument.Words
SingleWord = Trim(LCase(aWord))
If SingleWord < "a" Or SingleWord > "z" Then
SingleWord = "" 'Out of range?
NonWordObjects = NonWordObjects + 1 '
End If
If InStr(Excludes, "[" & SingleWord & "]") Then SingleWord = "" 'On
exclude list?
If Not bSpecifics Then
If Len(SingleWord) > 0 Then
lngProcessedWords = lngProcessedWords + 1
Found = False
For j = 1 To WordNum
If Words(j) = SingleWord Then
Freq(j) = Freq(j) + 1
Found = True
Exit For
End If
Next j
If Not Found Then
WordNum = WordNum + 1
Words(WordNum) = SingleWord
Freq(WordNum) = 1
End If
End If
Else
If Len(SingleWord) > 0 And InStr(Specifics, "{" & SingleWord & "}") Then
lngProcessedWords = lngProcessedWords + 1
Found = False
For j = 1 To WordNum
If Words(j) = SingleWord Then
Freq(j) = Freq(j) + 1
Found = True
Exit For
End If
Next j
If Not Found Then
WordNum = WordNum + 1
Words(WordNum) = SingleWord
Freq(WordNum) = 1
End If
End If
End If
Count = Count - 1
StatusBar = "Remaining: " & Count & " Unique: " & WordNum
Next aWord

'Now sort it into word order
For j = 1 To WordNum - 1
k = j
For l = j + 1 To WordNum
If (Not ByFreq And Words(l) < Words(k)) Or (ByFreq And Freq(l) >
Freq(k)) Then k = l
Next l
If k <> j Then
tword = Words(j)
Words(j) = Words(k)
Words(k) = tword
Temp = Freq(j)
Freq(j) = Freq(k)
Freq(k) = Temp
End If
StatusBar = "Sorting: " & WordNum - j
Next j

Count = ActiveDocument.Words.Count
TotalWords = Count - NonWordObjects

'Write out the results
tmpName = ActiveDocument.AttachedTemplate.FullName
Documents.Add Template:=tmpName, NewTemplate:=False
Set oRng = ActiveDocument.Range
With oRng
.ParagraphFormat.TabStops.ClearAll
For j = 1 To WordNum
.InsertAfter Words(j) & vbTab & Trim(Str(Freq(j))) & vbCrLf
Next j
.ConvertToTable
.Collapse wdCollapseStart
End With

Set oTbl = ActiveDocument.Tables(1)
oTbl.Rows.Add BeforeRow:=Selection.Rows(1)
oTbl.Cell(1, 1).Range.InsertBefore "Unique Words"
oTbl.Cell(1, 2).Range.InsertBefore "Number of Occurrences"
oTbl.Columns(2).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
Selection.Collapse wdCollapseStart
oTbl.Rows(1).Shading.BackgroundPatternColor = wdColorGray20
oTbl.Columns(1).PreferredWidth = InchesToPoints(4.75)
oTbl.Columns(2).PreferredWidth = InchesToPoints(1.9)

oTbl.Rows.Add
oTbl.Cell(oTbl.Rows.Count, 1).Range.InsertBefore "Summary"
oTbl.Cell(oTbl.Rows.Count, 2).Range.InsertBefore "Total"
oTbl.Rows(oTbl.Rows.Count).Shading.BackgroundPatternColor = wdColorGray20

If Not bSpecifics Then
oTbl.Rows.Add
oTbl.Cell(oTbl.Rows.Count, 1).Range.InsertBefore "Number of unique words
in Document"
oTbl.Cell(oTbl.Rows.Count, 2).Range.InsertBefore Trim(Str(WordNum))
oTbl.Rows(oTbl.Rows.Count).Shading.BackgroundPatternColor =
wdColorAutomatic
End If

oTbl.Rows.Add
oTbl.Cell(oTbl.Rows.Count, 1).Range.InsertBefore "Total number of reported
words in document"
oTbl.Cell(oTbl.Rows.Count, 2).Range.InsertBefore (lngProcessedWords)
If bSpecifics Then oTbl.Rows(oTbl.Rows.Count).Shading.BackgroundPatternColor
= wdColorAutomatic

oTbl.Rows.Add
oTbl.Cell(oTbl.Rows.Count, 1).Range.InsertBefore "Total number of words in
document"
oTbl.Cell(oTbl.Rows.Count, 2).Range.InsertBefore (TotalWords)
System.Cursor = wdCursorNormal

If Not bSpecifics Then
MsgBox "This document contains " & Trim(Str(WordNum)) & " unique words."
End If
MsgBox "This document contains " & lngProcessedWords & " reported words. "
MsgBox "This document contains a total of " & TotalWords & " words. "
MsgBox "For more statistics on this document, use Tools>Word Count in the
original document. "

ActiveDocument.Range(0, 0).Select

End Sub

 

[Suzanne]

Thanks to all... Suzanne

The various inputbox UI makes this rather crude and better suited for a
UserForm but I adapted some code that Doug Robbins has provided from time to
time to count and report unique words. I simply added the feature to
"exclude" words from processing or "designate" specific words to process
only.

Sub WordFrequency2()
Dim aWord As Range 'Raw word pulled from doc
Dim SingleWord As String 'Processed raw word
Dim Words() As String 'Array to hold unique words
Dim Freq() As Integer 'Frequency counter for Unique Words
Dim Ans As String 'Logic router
Dim WordNum As Integer 'Number of unique words
Dim ByFreq As Boolean 'Flag for sorting order
Dim Count As Long 'Total words in the document
Dim Excludes As String 'Words to be excluded
Dim Specifics As String 'Specific words to process
Dim bSpecifics As Boolean 'Logic router
Dim Found As Boolean 'Temporary flag
Dim j, k, l, Temp As Integer 'Temporary variables
Dim lngProcessedWords As Long 'Total processed words in document
Dim NonWordObjects As Long
Dim TotalWords As Long
Dim tword As String '
Dim tmpName
Dim oRng As Word.Range
Dim oTbl As Word.Table

Excludes = InputBox$("Enter words that you wish to exclude. " _
& "Place each word within square brackets [ ]. " _
& "Example: [is][a].", "Excluded Words", "")
If Len(Excludes) = 0 Then
Specifics = InputBox("Enter any specific words you wish to process. " _
& "Place each word withing squiggly brackets { }. " _
& "Example: {I}{me}{you}.", "Specific Words", "")
If Len(Specifics) > 0 Then bSpecifics = True
End If
'Find out how to sort
ByFreq = True
Ans = InputBox$("Default sort order is word freqeuncy." _
& " To sort alphabetically by word, type Word in the field below.",
"Sort order", "FREQ")
If Ans = "" Then End
If UCase(Ans) = "WORD" Then
ByFreq = False
End If
System.Cursor = wdCursorWait
WordNum = 0
Count = ActiveDocument.Words.Count
ReDim Words(Count)
ReDim Freq(Count)
'Control the repeat
For Each aWord In ActiveDocument.Words
SingleWord = Trim(LCase(aWord))
If SingleWord < "a" Or SingleWord > "z" Then
SingleWord = "" 'Out of range?
NonWordObjects = NonWordObjects + 1 '
End If
If InStr(Excludes, "[" & SingleWord & "]") Then SingleWord = "" 'On
exclude list?
If Not bSpecifics Then
If Len(SingleWord) > 0 Then
lngProcessedWords = lngProcessedWords + 1
Found = False
For j = 1 To WordNum
If Words(j) = SingleWord Then
Freq(j) = Freq(j) + 1
Found = True
Exit For
End If
Next j
If Not Found Then
WordNum = WordNum + 1
Words(WordNum) = SingleWord
Freq(WordNum) = 1
End If
End If
Else
If Len(SingleWord) > 0 And InStr(Specifics, "{" & SingleWord & "}") Then
lngProcessedWords = lngProcessedWords + 1
Found = False
For j = 1 To WordNum
If Words(j) = SingleWord Then
Freq(j) = Freq(j) + 1
Found = True
Exit For
End If
Next j
If Not Found Then
WordNum = WordNum + 1
Words(WordNum) = SingleWord
Freq(WordNum) = 1
End If
End If
End If
Count = Count - 1
StatusBar = "Remaining: " & Count & " Unique: " & WordNum
Next aWord

'Now sort it into word order
For j = 1 To WordNum - 1
k = j
For l = j + 1 To WordNum
If (Not ByFreq And Words(l) < Words(k)) Or (ByFreq And Freq(l) >
Freq(k)) Then k = l
Next l
If k <> j Then
tword = Words(j)
Words(j) = Words(k)
Words(k) = tword
Temp = Freq(j)
Freq(j) = Freq(k)
Freq(k) = Temp
End If
StatusBar = "Sorting: " & WordNum - j
Next j

Count = ActiveDocument.Words.Count
TotalWords = Count - NonWordObjects

'Write out the results
tmpName = ActiveDocument.AttachedTemplate.FullName
Documents.Add Template:=tmpName, NewTemplate:=False
Set oRng = ActiveDocument.Range
With oRng
.ParagraphFormat.TabStops.ClearAll
For j = 1 To WordNum
.InsertAfter Words(j) & vbTab & Trim(Str(Freq(j))) & vbCrLf
Next j
.ConvertToTable
.Collapse wdCollapseStart
End With

Set oTbl = ActiveDocument.Tables(1)
oTbl.Rows.Add BeforeRow:=Selection.Rows(1)
oTbl.Cell(1, 1).Range.InsertBefore "Unique Words"
oTbl.Cell(1, 2).Range.InsertBefore "Number of Occurrences"
oTbl.Columns(2).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
Selection.Collapse wdCollapseStart
oTbl.Rows(1).Shading.BackgroundPatternColor = wdColorGray20
oTbl.Columns(1).PreferredWidth = InchesToPoints(4.75)
oTbl.Columns(2).PreferredWidth = InchesToPoints(1.9)

oTbl.Rows.Add
oTbl.Cell(oTbl.Rows.Count, 1).Range.InsertBefore "Summary"
oTbl.Cell(oTbl.Rows.Count, 2).Range.InsertBefore "Total"
oTbl.Rows(oTbl.Rows.Count).Shading.BackgroundPatternColor = wdColorGray20

If Not bSpecifics Then
oTbl.Rows.Add
oTbl.Cell(oTbl.Rows.Count, 1).Range.InsertBefore "Number of unique words
in Document"
oTbl.Cell(oTbl.Rows.Count, 2).Range.InsertBefore Trim(Str(WordNum))
oTbl.Rows(oTbl.Rows.Count).Shading.BackgroundPatternColor =
wdColorAutomatic
End If

oTbl.Rows.Add
oTbl.Cell(oTbl.Rows.Count, 1).Range.InsertBefore "Total number of reported
words in document"
oTbl.Cell(oTbl.Rows.Count, 2).Range.InsertBefore (lngProcessedWords)
If bSpecifics Then oTbl.Rows(oTbl.Rows.Count).Shading.BackgroundPatternColor
= wdColorAutomatic

oTbl.Rows.Add
oTbl.Cell(oTbl.Rows.Count, 1).Range.InsertBefore "Total number of words in
document"
oTbl.Cell(oTbl.Rows.Count, 2).Range.InsertBefore (TotalWords)
System.Cursor = wdCursorNormal

If Not bSpecifics Then
MsgBox "This document contains " & Trim(Str(WordNum)) & " unique words."
End If
MsgBox "This document contains " & lngProcessedWords & " reported words. "
MsgBox "This document contains a total of " & TotalWords & " words. "
MsgBox "For more statistics on this document, use Tools>Word Count in the
original document. "

ActiveDocument.Range(0, 0).Select

End Sub

--
Greg Maxey/Word MVP
See:
http://gregmaxey.mvps.org/word_tips.htm
For some helpful tips using Word.

Hi Helmut,
I like it.
It's fast.
To help ignore case you could add something like the change I made below
for
the word "the"

Sub Test445B()
Dim rTmp As Range
Set rTmp = ActiveDocument.Sections(1).Range
With ActiveDocument.Tables(1)
.Cell(1, 1).Range.Text = "The or the"
.Cell(2, 1).Range.Text = "quick"
.Cell(3, 1).Range.Text = "brown"
.Cell(4, 1).Range.Text = "fox"
.Cell(1, 2).Range.Text = UBound(Split(LCase(rTmp.Text), "the"))
.Cell(2, 2).Range.Text = UBound(Split(rTmp.Text, "quick"))
.Cell(3, 2).Range.Text = UBound(Split(rTmp.Text, "brown"))
.Cell(4, 2).Range.Text = UBound(Split(rTmp.Text, "fox"))
End With
End Sub

 

[Greg Maxey]

Helmut, Russ

I went ahead and created a UserForm interface for this procedure and posted
it to my website:
http://gregmaxey.mvps.org/Word_Frequency.htm

 

[Russ]

I'm sure many people will find this useful, Greg. Thanks.

I would only suggest altering the code now, so the user only has to
minimally enter the include and exclude words without braces or brackets to
save some typing for the user.

For example the user could enter words separated by spaces. You then pad
that entry with a space character before and after the whole user entry
string. And then the instr search could be for each document word padded
with a space before and after, instead of the braces and brackets.

 

[Russ]

Greg,
I just had a thought. That one of the advantages of the braces and brackets
is that they allow for phrases that include other punctuation like spaces.
Maybe you could adapt the code so the user uses space delimiters for single
regular words and have a third input line for phrases delimited with braces.
Or a fourth input line to let the user input what he wants to use for phrase
delimiters. I realize the phrase search would require a separate search loop
and might be adding too much complication to the process. Just a thought.


I also still like Helmut's method as a way for counting phrases.
UBound(Split(ActiveDocument.Range.Text, "This is a phrase.", vbTextCompare))

 

[Greg Maxey]

Russ,

Thanks for the comments. You sound a bit like me. Whenever I get something
working OK, I want to keep tinkering with it to make it better ;-). This
one is on the shelf right now, but I may come back later and tweak it using
some of your ideas.

 

[Ernie]

Hi Helmut and All:
I have a problem with using VBA behind a Word 2003 document to count the
occurrences of names. I have two versions, one which works and one that does
not work properly even though it is a bit more elegant, i.e. uses a
Function() cad some Calls. How can I transmit these documents to you? Do you
have an email address that I could use?

 

[Helmut Weber]

Hi Ernie

Sub Test7c()
Dim s1 As String
Dim s2 As String
Dim i As Long
s1 = "(e-mail address removed)"
For i = Len(s1) To 1 Step -1
s2 = s2 & Mid(s1, i, 1)
Next
MsgBox s2
End Sub

--

Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Vista Small Business, Office XP