Word VBA - count of specific words in document?

John Smoth

unread,

Jun 17, 2003, 3:38:54 AM6/17/03

to

Hello,

I would like to be able to count all the times a number of key words are
used in reports I receive. For instance, if I was checking for colors I'd
like to count the number of times "Red", "Green", "Blue" were used in the
text.

Is this possible using VBA or a macro at all?

As you can tell, I have very little experience but I am sure this must be
possible somehow. All tips would be appreciated.

Many thanks
John

Doug Robbins - Word MVP

unread,

Jun 17, 2003, 5:40:07 AM6/17/03

to

Hi John,

You could modify this, but it might he easier to just run it as it is and
then look for the words that you are interested in in the result:

Sub WordFrequency()

Dim SingleWord As String 'Raw word pulled from doc
Const maxwords = 9000 'Maximum unique words allowed
Dim Words(maxwords) As String 'Array to hold unique words
Dim Freq(maxwords) As Integer 'Frequency counter for Unique
Words
Dim WordNum As Integer 'Number of unique words
Dim ByFreq As Boolean 'Flag for sorting order
Dim ttlwds As Long 'Total words in the document
Dim Excludes As String 'Words to be excluded
Dim Found As Boolean 'Temporary flag
Dim j, k, l, Temp As Integer 'Temporary variables
Dim tword As String '

' Set up excluded words
' Excludes =
"[the][a][of][is][to][for][this][that][by][be][and][are]"
Excludes = ""
Excludes = InputBox$("Enter words that you wish to exclude,
surrounding each word with [ ].", "Excluded Words", "")
' Excludes = Excludes & InputBox$("The following words are excluded:
" & Excludes & ". Enter words that you wish to exclude, surrounding each
word with [ ].", "Excluded Words", "")
' Find out how to sort
ByFreq = True
Ans = InputBox$("Sort by WORD or by FREQ?", "Sort order", "FREQ")
If Ans = "" Then End
If UCase(Ans) = "WORD" Then
ByFreq = False
End If

Selection.HomeKey Unit:=wdStory
System.Cursor = wdCursorWait
WordNum = 0
ttlwds = ActiveDocument.Words.Count
Totalwords = ActiveDocument.Words.Count

' Control the repeat
For Each aword In ActiveDocument.Words
SingleWord = Trim(aword)
If SingleWord < "A" Or SingleWord > "z" Then SingleWord = ""
'Out of range?
If InStr(Excludes, "[" & SingleWord & "]") Then SingleWord = ""
'On exclude list?
If Len(SingleWord) > 0 Then
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
If WordNum > maxwords - 1 Then
j = MsgBox("The maximum array size has been exceeded.
Increase maxwords.", vbOKOnly)
Exit For
End If
End If
ttlwds = ttlwds - 1
StatusBar = "Remaining: " & ttlwds & " 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

' Now write out the results
tmpName = ActiveDocument.AttachedTemplate.FullName
Documents.Add Template:=tmpName, NewTemplate:=False
Selection.ParagraphFormat.TabStops.ClearAll
With Selection
For j = 1 To WordNum
.TypeText Text:=Words(j) & vbTab & Trim(Str(Freq(j))) &
vbCrLf
Next j
End With
ActiveDocument.Range.Select
Selection.ConvertToTable
Selection.Collapse wdCollapseStart
ActiveDocument.Tables(1).Rows.Add BeforeRow:=Selection.Rows(1)
ActiveDocument.Tables(1).Cell(1, 1).Range.InsertBefore "Word"
ActiveDocument.Tables(1).Cell(1, 2).Range.InsertBefore
"Occurrences"
ActiveDocument.Tables(1).Range.ParagraphFormat.Alignment =
wdAlignParagraphCenter
ActiveDocument.Tables(1).Rows.Add
ActiveDocument.Tables(1).Cell(ActiveDocument.Tables(1).Rows.Count,
1).Range.InsertBefore "Total words in Document"
ActiveDocument.Tables(1).Cell(ActiveDocument.Tables(1).Rows.Count,
2).Range.InsertBefore Totalwords
ActiveDocument.Tables(1).Rows.Add
ActiveDocument.Tables(1).Cell(ActiveDocument.Tables(1).Rows.Count,
1).Range.InsertBefore "Number of different words in Document"
ActiveDocument.Tables(1).Cell(ActiveDocument.Tables(1).Rows.Count,
2).Range.InsertBefore Trim(Str(WordNum))
System.Cursor = wdCursorNormal
' j = MsgBox("There were " & Trim(Str(WordNum)) & " different words
", vbOKOnly, "Finished")
Selection.HomeKey wdStory

End Sub

--
Please respond to the newsgroups for the benefit of others who may be
interested.

Hope this helps
Doug Robbins - Word MVP
"John Smoth" <jsm...@nospam.jsmoth.com> wrote in message
news:3eeec590$0$10624$cc9e...@news.dial.pipex.com...

Andrew Savikas

unread,

Jun 17, 2003, 12:05:55 PM6/17/03

to

This is pretty compact, and should be easy to modify as
needed. Displays a message box at the end with the results
(you could instead insert as a table into a new document,
if you'd like).

Sub wordcount()
Dim wrd As Range
Dim var As Variant
Dim searchlist()
Dim numfound() As Integer
Dim idx As Integer
Dim strResults As String
'Add as many words as you'd like to this list
searchlist = Array("Red", "Green", "Blue")
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

HTH,
Andrew Savikas

>.
>

Perry

unread,

Jun 17, 2003, 5:34:26 PM6/17/03

to

Here's another example

Type arrWords
Text As String
Occur As Long
End Type

Sub FindText()
Dim MyArray(3) As arrWords
Dim r As Word.Range
Dim lOccur As Long

MyArray(0).Text = "Red"
MyArray(1).Text = "Green"
MyArray(2).Text = "Blue"

For x = 0 To UBound(MyArray)
Set r = ActiveDocument.Range
With r.Find
.ClearFormatting
.Text = MyArray(x).Text
.Wrap = wdFindStop
lOccur = MyArray(x).Occur
Do While .Execute
lOccur = IIf(.Found, lOccur + 1, lOccur)
Loop
End With
MyArray(x).Occur = lOccur
lOccur = 0
Next

'show occurences of "Blue"
MsgBox MyArray(2).Text & vbCr & MyArray(2).Occur

End Sub

Krgrds,
Perry

"John Smoth" <jsm...@nospam.jsmoth.com> schreef in bericht
news:3eeec590$0$10624$cc9e...@news.dial.pipex.com...

John Smoth

unread,

Jun 18, 2003, 3:08:05 AM6/18/03

to

Thank you all very much indeed! These have far exceeded my hopes at this
stage - I'll spend some time to understand the logic and I'm sure that
between them I will have what I'm looking for.

Many thanks again,
Regards
John

"John Smoth" <jsm...@nospam.jsmoth.com> wrote in message
news:3eeec590$0$10624$cc9e...@news.dial.pipex.com...

Dammy gell

unread,

Jan 4, 2024, 2:33:03 PMJan 4

to

TELEGRAM LINK
https://t.me/dammygell45
https://t.me/dammygell45

Mushroom chocolate bars have captured the imagination of food enthusiasts and health-conscious individuals alike. This intriguing combination brings together the earthy goodness of mushrooms and the indulgent delight of chocolate, creating a unique culinary experience that is both delicious and intriguing.

Telegram link:
https://t.me/dammygell45

Beyond the taste, these bars have gained attention for their potential health benefits and therapeutic properties. In this article, we will delve into the science behind the magic of mushroom chocolate bars, exploring the fascinating chemical composition of mushrooms, uncovering the role of mycelium, and unraveling the secrets of mushroom compounds like psilocybin. Join us on this exploration as we discover the captivating world of mushroom chocolate bars and understand how they work their magic.

Polka Dot Chocolate Bars For sale | Magic Belgian Chocolate | Buy Polka Dot Magic Belgian Chocolate Bar
https://t.me/dammygell45
https://t.me/dammygell45

Links To More Chocolate Bars
Buy cap up bar:

Buy fusion bars

Buy Winder Bar Mushroom Chocolate Bar

Buy Shroomies Microbites Assorted Gummies USA:

Buy Trippy Treats Mushrooms Chocolate Bars | Trippy Chocolate Bars:

Buy Psilo Gummies California| Psilocybin Mushroom Gummies

Magic Boom Bar | Buy Magic Mushroom Chocolate Bahttps

Buy Green Apple Mushroom Gummies

Buy Dark Chocolates:

Buy One Up Chocolate Bar | One Up Mushroom Bar For Sale

Buy Trippy Flipp Mushroom Chocolate bars

Cherry Chocolate Gummies:
https://t.me/dammygell45
https://t.me/dammygell45

John Kay

unread,

Jan 22, 2024, 2:33:33 PMJan 22

to

TELEGRAM link
https://t.me/YotyRandy842
https://t.me/YotyRandy842

We have many products on DMT, LSD, MDMA, Psilocybin Magic mushrooms, cannabis, and microdosing psychedelics. Buy Highest Quality DMT Carts, XTC Pills, LSD Edibles, Shrooms Chocolates, Psychedelics Magic Mushrooms Gummies Online In USA ✓ Great Prices ✓ Trusted psychedelics vendor with tracking ✓ Fast Delivery worldwide.

US-US Delivery
Fast Shipping
Secure Payment Options
100% Satisfaction Guaranteed
3 Days Refund Policy
100% Money-Back if any issue with the product
Shipping Service: Overnight/Standard/Economy
Estimated Delivery Time: Overnight & 3-5 Days
Discounts: Get up to 20% off
Shipping Rates – USPS: $30 FedEx: $45 Only USA.
Pay With Credit / Debit Cards Also
CLICK ➤HERE ➤TO ➤BUY ➤DMT➤ONLINE

We sell the highest-quality DMT vape cartridges, LSD edibles, and Psilocybin chocolate bars for microdosing, with a focus on sourcing from premium suppliers.

Telegram link
https://t.me/YotyRandy842

Buy DMT Vape Cartridges And Microdose DMT USA Online
https://t.me/YotyRandy842
https://t.me/YotyRandy842

Buy LSD Microdoses And LSD Edibles Online

Buy Psilocybin Mushroom And Mushroom Microdoses

Buy 100ML 4-ACO-DMT Microdosing Kit

Buy 5-MeO DMT .5ml Purecybin Carts:

https://t.me/YotyRandy842
https://t.me/YotyRandy842

Buy 4-AcO-DMT Freebase:

https://t.me/YotyRandy842

Buy 5-MeO-DMT Cartridge 1mL:

https://t.me/YotyRandy842
https://t.me/YotyRandy842
Buy Deadhead Chemist DMT (Vape and Cartridge) 1mL:

Buy DeadHead Chemist DMT Vape Cartridge:

Buy DMT .5ml Purecybin – 300mg DMT
https://t.me/YotyRandy842

Buy DMT (Free Base)DMT 1ml 800mg DMT Vape – Mushrooms Canada
https://t.me/YotyRandy842