Writer&';s Friend


by Dale Stubbart

WrF_Word_Frequency

Donate here

Sub WrF_Word_Frequency()
Const maxwords = 9000
Dim Words(maxwords) As String
Dim Freq(maxwords) As Integer
Dim SingleWord As String
Dim MinFreq: MinFreq = 10
Dim CombineWords As Boolean: CombineWords = True
If Selection.Type = wdSelectionIP Then
Selection.WholeStory
End If
System.Cursor = wdCursorWait
WordNum = 0
For Each wordi In Selection.Words
SingleWord = Trim(LCase(wordi))
If WrF_Word_Frequency_Check_SingleWord(SingleWord) > "" Or (Trim(UCase(wordi)) = Trim(wordi) And SingleWord >= "a" And SingleWord <= "z" And Len(SingleWord) >= 3) Then
If CombineWords Then
SingleWord = Wrf_Word_Frequency_Combine_Words(SingleWord)
End If
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("Too many words.", vbOKOnly)
Exit For
End If
End If
Next wordi
For j = 1 To WordNum - 1
k = j
For l = j + 1 To WordNum
If Freq(l) > Freq(k) Then
k = l
End If
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
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
If Freq(j) >= MinFreq Then
.TypeText Text:=Trim(Str(Freq(j))) & vbTab & Words(j) & vbCrLf
End If
Next j
End With
Selection.HomeKey Unit:=wdStory
System.Cursor = wdCursorNormal
End Sub
Function WrF_Word_Frequency_Check_SingleWord(SingleWord As String)
Dim Includes2 As String
Includes2 = "[ab][ad][ax][ed][ex][go][id][jo][pi][ox][up]"
Dim Check3 As Boolean: Check3 = True
Dim Includes3 As String
Includes3 = "[abe][ace][act][add][age][air][all][alm][ann][ape][apr][arm][art][ask][ate][aug][awe][awl]"
Includes3 = Includes3 & "[bad][bag][ban][bar][bat][bed][bee][bib][bid][big][bit][boa][bob][bod][bog][box][bow][boy][bud][bug][bum][bun][bus]"
Includes3 = Includes3 & "[cab][cad][cam][cal][car][cat][cob][cog][cop][cot][cow][cry][cub][cud][cue][cup][cut]"
Includes3 = Includes3 & "[dab][dad][dan][day][deb][dec][dee][dew][die][dig][din][dip][dog][don][dot][dud][dug][dye][ear][eat][end][eve][ewe]"
Includes3 = Includes3 & "[fab][fad][far][fat][feb][fed][fee][few][fib][fin][fir][fit][flo][fly][fob][foe][fog][fop][fox][fri][fry][fun][fur]"
Includes3 = Includes3 & "[gab][gad][gas][gay][gin][gum][gun][gut][ham][hay][hoe][hog][hon][hot][hub][hug][hum][hun][hut]"
Includes3 = Includes3 & "[ida][ide][ill][ire][ivy][jab][jam][jan][jar][jen][jib][job][jog][jot][joy][jug][jul][jun][jut]"
Includes3 = Includes3 & "[lab][lad][lag][lam][lap][lat][lay][led][lee][leg][lib][lid][lie][lip][lit][lob][log][lop][lot][low][lug][lye]"
Includes3 = Includes3 & "[mac][mad][mae][mag][man][map][mar][mat][may][men][met][mew][mob][moe][mom][mon][mop][mow][mud][mug]"
Includes3 = Includes3 & "[nab][nag][nan][nap][nat][nay][ned][net][new][nod][nov][now][oaf][oar][obi][oct][odd][ode][off][old][ole][one][ore][ort][out]"
Includes3 = Includes3 & "[pad][pal][pam][pan][par][pat][pay][pea][pen][pep][pet][pie][pig][pin][pit][pop][pot][pox][pow][pry][pub][pug][pun][put]"
Includes3 = Includes3 & "[rad][rag][ran][rap][rat][ray][reb][red][ref][reg][ren][rob][rod][roe][ron][rot][row][rub][rue][run][rut][rye]"
Includes3 = Includes3 & <"[sad][sag][sal][sam][sat][saw][say][sea][see][sep][set][sew][shy][sib][sid][sin][sit][six][sob][sod][son][sox][sow][soy][sub][sun]"
Includes3 = Includes3 & "[tab][tad][tan][tar][ted][ten][thu][tim][tip][toe][tom][tot][tow][toy][tub][tue][tug][tut][try][two]"
Includes3 = Includes3 & "[urn][use][van][vat][wad][wan][war][wax][way][web][wed][wee][wet][wig][win][wit][woe][won][wry][yea][yen][yes][zap][zip][zoo]"
Dim Excludes4 As String
Excludes4 = "[alas][also][been][both][does][each][else][from][have][he'd][he's][here][i'll][into][it's][i've]"
Excludes4 = Excludes4 & "[less][lets][like][made][make][mine][more][most][much][only][over][same][self][some][than][that][them][then][they][this][thus]"
Excludes4 = Excludes4 & "[upon][very][what][went][were][when][with][your]"
Dim Excludes5 As String
Excludes5 = "[about][again][ain't][along][being][can't][c'mon][could][doing][don't][every][he'll][isn't]"
Excludes5 = Excludes5 & "[least][let's][makes][ne'er][never][noone][other][she'd][she's][since][their][there][these][thing][those]"
Excludes5 = Excludes5 & "[until][usual][wants][we're][we've][where][which][while][who's][whose][won't][would][you'd][yours]"
Dim Excludes6 As String
Excludes6 = "[almost][always][anyone][become][beside][cannot][didn't][either][gotten][hadn't][here's][itself][myself][others][rather][selves][she'll]"
Excludes6 = Excludes6 & "[that's][they'd][things][though][wasn't][what's][within][you'll][you're][you've]"
Dim Excludes7 As String
Excludes7 = "[another][anytime][because][besides][doesn't][getting][haven't][herself][himself][however][nothing][nowhere][perhaps][should][someone]"
Excludes7 = Excludes7 & "[there's][they'll][they're][they've][through][usually][weren't][whereas][without]"
Dim Excludes8 As String
Excludes8 = "[anything][anywhere][everyone][couldn't][sometime][wouldn't][yourself]"
Dim Excludes9 As String
Excludes9 = "[otherwise][someother][sometimes][something][theirself]"
Dim Excludes10 As String
Excludes10 = "[anything's][everything],[everywhere][themselves][yourselves]"
Dim Excludes11 As String
Excludes11 = ""
Dim Excludes12 As String
Excludes12 = "[everything's]"
Includes3 = Replace(Includes3, "'", Chr(146))
Excludes4 = Replace(Excludes4, "'", Chr(146))
Excludes5 = Replace(Excludes5, "'", Chr(146))
Excludes6 = Replace(Excludes6, "'", Chr(146))
Excludes7 = Replace(Excludes7, "'", Chr(146))
Excludes8 = Replace(Excludes8, "'", Chr(146))
Excludes9 = Replace(Excludes9, "'", Chr(146))
Excludes10 = Replace(Excludes10, "'", Chr(146))
If SingleWord < "a" Or SingleWord > "z" Then
WrF_Word_Frequency_Check_SingleWord = ""
Exit Function
End If
If Len(SingleWord) < 2 Then
WrF_Word_Frequency_Check_SingleWord = ""
Exit Function
End If
If Len(SingleWord) = 2 Then
If InStr(Includes2, "[" & SingleWord & "]") Then
WrF_Word_Frequency_Check_SingleWord = SingleWord
Else
WrF_Word_Frequency_Check_SingleWord = ""
End If
Exit Function
End If
If Len(SingleWord) = 3 And Check3 Then
If InStr(Includes3, "[" & SingleWord & "]") Then
WrF_Word_Frequency_Check_SingleWord = SingleWord
Else
WrF_Word_Frequency_Check_SingleWord = ""
End If
Exit Function
End If
If Len(SingleWord) = 4 Then
If InStr(Excludes4, "[" & SingleWord & "]") Then
WrF_Word_Frequency_Check_SingleWord = ""
Else
WrF_Word_Frequency_Check_SingleWord = SingleWord
End If
Exit Function
End If
If Len(SingleWord) = 5 Then
If InStr(Excludes5, "[" & SingleWord & "]") Then
WrF_Word_Frequency_Check_SingleWord = ""
Else
WrF_Word_Frequency_Check_SingleWord = SingleWord
End If
Exit Function
End If
If Len(SingleWord) = 6 Then
If InStr(Excludes6, "[" & SingleWord & "]") Then
WrF_Word_Frequency_Check_SingleWord = ""
Else
WrF_Word_Frequency_Check_SingleWord = SingleWord
End If
Exit Function
End If
If Len(SingleWord) = 7 Then
If InStr(Excludes7, "[" & SingleWord & "]") Then
WrF_Word_Frequency_Check_SingleWord = ""
Else
WrF_Word_Frequency_Check_SingleWord = SingleWord
End If
Exit Function
End If
If Len(SingleWord) = 8 Then
If InStr(Excludes8, "[" & SingleWord & "]") Then
WrF_Word_Frequency_Check_SingleWord = ""
Else
WrF_Word_Frequency_Check_SingleWord = SingleWord
End If
Exit Function
End If
If Len(SingleWord) = 9 Then
If InStr(Excludes9, "[" & SingleWord & "]") Then
WrF_Word_Frequency_Check_SingleWord = ""
Else
WrF_Word_Frequency_Check_SingleWord = SingleWord
End If
Exit Function
End If
If Len(SingleWord) = 10 Then
If InStr(Excludes10, "[" & SingleWord & "]") Then
WrF_Word_Frequency_Check_SingleWord = ""
Else
WrF_Word_Frequency_Check_SingleWord = SingleWord
End If
Exit Function
End If
If Len(SingleWord) = 11 Then
If InStr(Excludes11, "[" & SingleWord & "]") Then
WrF_Word_Frequency_Check_SingleWord = ""
Else
WrF_Word_Frequency_Check_SingleWord = SingleWord
End If
Exit Function
End If
If Len(SingleWord) = 12 Then
If InStr(Excludes12, "[" & SingleWord & "]") Then
WrF_Word_Frequency_Check_SingleWord = ""
Else
WrF_Word_Frequency_Check_SingleWord = SingleWord
End If
Exit Function
End If
WrF_Word_Frequency_Check_SingleWord = SingleWord
End Function
Function WrF_Word_Frequency_Combine_Words(SingleWord As String)
Dim Comb As String
Comb = "[adds][added][adding]*add*[allows][allowed][allowing]*allow*[alumni]*alumnus*[analyses]*analysis*[animals]*animal*"
Comb = Comb & "[appears][appeared][appearing]*appear*[asks][asked][asking]*ask*"
Comb = Comb & "[becomes][became][becoming]*become*[begins][began]*begin*[believes][believed][believing]*believe*"
Comb = Comb & "[breaks][broken][breaking]*break*[brings][brought][bringing]*bring*[builds][built]*build*[buys][bought][buying]*buy*"
Comb = Comb & "[cacti]*cactus*[calves]*calf*[calls][called][calling]*call*[cars]*car*[changes][changed][changing]*change*[children]*child*[clings][clung][clinging]*cling*"
Comb = Comb & "[came][comes][coming]*come*[communities]*community*[considers][considered][considering]*consider*[continues][continued][continuing]*continue*"
Comb = Comb & "[creates][created][creating]*create*[crises]*crisis*[curricula][curriculums]*curriculum*[cuts][cutting]*cut*"
Comb = Comb & "[days]*day*[decides][decided][deciding]*decide*[dies][died]*die*[drives][drove][driving]*drive*[expects][expected][expecting]*expect*"
Comb = Comb & "[falls][fell][fallen][falling]*fall*[feels][feeling]*feel*[finds][found][finding]*find*[foci]*focus*[follows][followed][following]*follow*[feet]*foot*[fungi]*fungus*"
Comb = Comb & "[gave][gives][given][giving]*give*[goes][went][gone][going]*go*[geese]*goose*[grows][grown][grew][growing]*grow*"
Comb = Comb & "[happens][happened][happening]*happen*[hears][heard][hearing]*hear*[helps][helped][helping]*help*[heroes]*hero*"
Comb = Comb & "[hippopotami][hippopotamuses]*hippopotamus*[holds][held][holding]*hold*[hours]*hour*[hybrids]*hybrid*"
Comb = Comb & "[ideas]*idea*[includes][included][including]*include*"
Comb = Comb & "[keeps][kept][keeping]*keep*[kills][killed][killing]*kill*[knives]*knife*[knew][known][knows][knowing]*know*"
Comb = Comb & "[leads][led][leading]*lead*[learns][learned][learning]*learn*[likes][liked][liking]*like*[lived][living]*live*"
Comb = Comb & "[looks][looked][looking]*look*[loses][lost][losing]*lose*[lice]*louse*[loves][loved][loving]"
Comb = Comb & "[made][makes][making]*make*[men]*man*[meets][met][meeting]*meet*[minutes]*minute*[months]*month*[mice]*mouse*[moves][moved][moving]*move*"
Comb = Comb & "[needs][needed][needing]*need*[nuclei]*nucleus*"
Comb = Comb & "[octopi][octopuses]*octopus*[offers][offered][offering]*offer*[ones]*one*[opens][opened][opening]*open*[oxen]*ox*"
Comb = Comb & "[passes][passed][passing]*pass*[pays][paid][paying]*pay*[people]*person*[phenomona]*phenomenon*[plays][played][playing]*play*[potatoes]*potato*"
Comb = Comb & "[provides][provided][providing]*provide*[pulls][pulled][pulling]*pull*"
Comb = Comb & "[radii]*radius*[raids][raided][raiding]*raid*[raises][raised][raising]*raise*[rakes][raked][raking]*rake*[ranges][ranged][ranging]*range*"
Comb = Comb & "[reaches][reached][reaching]*reach*[reads][reading]*read*"
Comb = Comb & "[remains][remained][remaining]*remain*[remembers][remembered][remembering]*remember*[reports][reported][reporting]*report*[requires][required][requiring]*require*"
Comb = Comb & "[rings][rang][ringing]*ring*[roads]*road*[runs][ran][running]*run*"
Comb = Comb & "[said][says][saying]*say*"
Comb = Comb & "[seconds]*second*[sees][seen][seeing]*see*[seems][seemed][seeming]*seem*[sells][sold][selling]*sell*[sends][sent][sending]*send*[serves][served][serving]*serve*"
Comb = Comb & "[ships]*ship*[shows][shown][showed][showing]*show*"
Comb = Comb & "[sings][sang][singing]*sing*[sits][sat][sitting]*sit*[speaks][spake][spoke][speaking]*speak*[spends][spent][spending]*spend*"
Comb = Comb & "[stands][stood][standing]*stand*[starts][started][starting]*start*[stays][stayed][staying]*stay*[stops][stopped][stopping]*stop*"
Comb = Comb & "[suggests][suggested][suggesting]*suggest*"
Comb = Comb & "[takes][taken][took][taking]*take*[talks][talked][talking]*talk*[tells][theses]*thesis*[technologies]*technology*[told][telling]*tell*[thinking][thinks][thought]*think*"
Comb = Comb & "[tomatoes]*tomato*[teeth]*tooth*[torpedoes]*torpedo*[tries][tried][trying]*try*[turns][turned][turning]*turn*"
Comb = Comb & "[understands][understood][understanding]*understand*[uses][used][using]*use*[vetoes]*veto*"
Comb = Comb & "[waits][waited][waiting]*wait*[walks][walked][walking]*walk*[wants][wanted][wanting]*want*[watches][watched][watching]*watch*[waters]*water*"
Comb = Comb & "[wheels]*wheel*[wives]*wife*[wins][won][winning]*win*"
Comb = Comb & "[women]*woman*[works][worked][working]*work*[writes][wrote][written][writing]*write*[years]*year*"
i = InStr(Comb, "[" & SingleWord & "]")
If i > 0 Then
j = InStr(i, Comb, "*") + 1
k = InStr(j, Comb, "*") - 1
l = k - j + 1
Wrf_Word_Frequency_Combine_Words = Mid$(Comb, j, l)
Else
If Right(SingleWord, 2) = Chr(146) & "s" Then
Wrf_Word_Frequency_Combine_Words = Left(SingleWord, Len(SingleWord) - 2)
Else
Wrf_Word_Frequency_Combine_Words = SingleWord
End If
End If
End Function