VBA Macro to create Word & Phrase Frequency

[Akuini]

Akuini submitted a new Excel article:

VBA Macro to create Word & Phrase Frequency - VBA Macro to create Word & Phrase Frequency

This macro generates word & phrase frequency.
You can set the number of words contained in a phrase as needed, in this part:
Const sNumber As String = "1,2,3"
You can also set what characters should be considered as word characters, in this part:
Const xPattern As String = "A-Z0-9_'"
but you will need basic knowledge of regular expressions.

Tested on a text (from a novel) with 93623 rows (in the sheet), 586552 total...

Read more about this Excel article...

 

[BThis]

Hello Akuini, would you have a version of this for Word? I don't need phrases, just counts of each word in Word documents, excluding common words like a, an, the, is, and, etc. I have found two such macros but receive syntax errors when I try and run them. I have many documents I need to run this on.

 

[Akuini]

@BThis
Sorry, I don't have the macro to do that in Word. But I found this Word macro "Sub WordFrequency" from Allen Wyatt:
Generating a Count of Word Occurrences

and you can set up excluded words as needed.

 

[wiscochris]

This script is AMAZING! I've never seen anything like it and I've been searching for YEARS. Thanks very, very much for sharing.
One thing that would be absolutely huge would be the ability to add a list of stop words. Is that something you would possibly consider adding.
Thanks again for sharing this awesome macro

 

[Akuini]

@wiscochris, welcome to MrExcel
I'm glad that you find the code useful.

One thing that would be absolutely huge would be the ability to add a list of stop words.

Not sure what you want to do with the stop words, but my understanding is that you don't want to count it, so it won't be part of the words count.
I added "sub stopWord" to remove the stop words.
How it works:

1. Put the text in column A, start at A1.
2. Put the list of stop words starting at B1 (cell B1 must not be empty).
3. Run "Sub Word_Phrase_Frequency_v1".
4. The code will replace all stop words (case insensitive) found in the text (on col A) with a "|", so it won't be counted as word.

Speed test:
Using stop words can actually speed up the process, I tested it on a novel i.e. War and Peace, by Leo Tolstoy, it contains 586930 words.
Without stop words it took 41.87891 seconds.
With 70 words as stop words it took only 12.375 seconds.

Example:

dhee - stop word try.xlsm
	A	B	C	D	E	F	G	H
1	The book	a		1 WORD	COUNT		2 WORD	COUNT
2	War and Peace, by Leo Tolstoy	the		book	1		book War	1
3		and		Leo	1		Leo Tolstoy	1
4		by		Peace	1
5				Tolstoy	1
6				War	1
Sheet1

Option Explicit

Sub Word_Phrase_Frequency_v1()

'The code will generate word/phrase frequency
'How to use:
'1. Add reference to "Microsoft VBScript Regular Expressions 5.5" (you need to do it once only):
'   In Visual Basic Editor menu, select Tools –> References, then select Microsoft VBScript Regular Expressions 5.5, then click OK.
'2. Data must be in column A, start at A1
'3. Run Word_Phrase_Frequency_v1


'--- CHANGE sNumber & xPattern VALUE TO SUIT -----------------------------------

Const sNumber As String = "1,2,3"  '"1,2,3"
'sNumber = "1"  will generate 1 word frequency list
'sNumber = "1,2,3"  will generate 1 word, 2 word & 3 word frequency list

Const xPattern As String = "A-Z0-9_'"
'define the word characters, the above pattern will include letter, number, underscore & apostrophe as word character
'word with apostrophe such as "you're" counts as one word.
'word with underscore such as "aa_bb" counts as one word.


Const xCol As String = "C:ZZ" 'columns to clear
Dim i As Long, j As Long
Dim txa As String
Dim z, t

t = Timer
Application.ScreenUpdating = False
Range(xCol).Clear

'if there are errors, remove them
On Error Resume Next
Range("A:A").SpecialCells(xlCellTypeFormulas, xlErrors).ClearContents
Range("A:A").SpecialCells(xlConstants, xlErrors).ClearContents
On Error GoTo 0

j = Range("A" & Rows.Count).End(xlUp).Row

If j < 65000 Then
    txa = Join(Application.Transpose(Range("A1", Cells(Rows.Count, "A").End(xlUp))), " ")
Else
    For i = 1 To j Step 65000
    txa = txa & Join(Application.Transpose(Range("A" & i).Resize(65000)), " ") & " "
    Next
End If

'if you have stop words list then put the list starting at B1
If Range("B1") <> "" Then Call stopWord(xPattern, txa)

z = Split(sNumber, ",")
    
    'TO PROCESS
    For i = LBound(z) To UBound(z)
        Call toProcessY(CLng(z(i)), txa, xPattern)
    Next

Range(xCol).Columns.AutoFit
Application.ScreenUpdating = True

Debug.Print "It's done in:  " & Timer - t & " seconds"

End Sub


Sub stopWord(xP As String, tx As String)
Dim n As Long
Dim stW, x
Dim regEx As Object
n = Range("B" & Rows.Count).End(xlUp).Row
If n = 1 Then Exit Sub
stW = Range("B1:B" & n)

        Set regEx = CreateObject("VBScript.RegExp")
        With regEx
            .Global = True
            .MultiLine = True
            .Ignorecase = True
        End With
tx = " " & tx
For Each x In stW
        regEx.Pattern = "[^" & xP & "]" & x & "[^" & xP & "]"
        If regEx.Test(tx) Then
           tx = regEx.Replace(tx, "|")   'replace stop word with "|"
        End If
Next

End Sub

Sub toProcessY(n As Long, ByVal tx As String, xP As String)
'phrase frequency

Dim regEx As Object, matches As Object, x As Object, d As Object
Dim i As Long, rc As Long
Dim va, q

        Set regEx = CreateObject("VBScript.RegExp")
        With regEx
            .Global = True
            .MultiLine = True
            .Ignorecase = True
        End With

If n > 1 Then

        regEx.Pattern = "( ){2,}"

        If regEx.Test(tx) Then
           tx = regEx.Replace(tx, " ") 'remove excessive space
        End If
        
        tx = Trim(tx)
               
'        regEx.Pattern = "[^A-Z0-9_' ]+"
        regEx.Pattern = "[^" & xP & " ]+" 'exclude xp and space
        If regEx.Test(tx) Then
           tx = regEx.Replace(tx, vbLf) 'replace non words character (excluding space) with new line char (vbLf)
        End If
        
        tx = Replace(tx, vbLf & " ", vbLf & "") 'remove space in the beginning of every line

End If

    Set d = CreateObject("scripting.dictionary")
    d.CompareMode = vbTextCompare

'    regEx.Pattern = Trim(WorksheetFunction.Rept("[A-Z0-9_']+ ", n)) 'match n words (the phrase) separated by a space
    regEx.Pattern = Trim(WorksheetFunction.Rept("[" & xP & "]+ ", n)) 'match n words (the phrase) separated by a space
            Set matches = regEx.Execute(tx)
            
            For Each x In matches
                d(CStr(x)) = d(CStr(x)) + 1 'get phrase frequency
            Next
 
For i = 1 To n - 1
        
        regEx.Pattern = "^[" & xP & "]+ "
        If regEx.Test(tx) Then
           tx = regEx.Replace(tx, "")   'remove first word in each line to get different combination of n words (phrase)

'            regEx.Pattern = Trim(WorksheetFunction.Rept("[A-Z0-9_']+ ", n))
            regEx.Pattern = Trim(WorksheetFunction.Rept("[" & xP & "]+ ", n))
            
            Set matches = regEx.Execute(tx)
            
            For Each x In matches
                d(CStr(x)) = d(CStr(x)) + 1     'get phrase frequency
            Next

        End If
Next

If d.Count = 0 Then MsgBox "Nothing with " & n & " word phrase found": Exit Sub

rc = Cells(1, Columns.Count).End(xlToLeft).Column
'put the result

With Cells(2, rc + 2).Resize(d.Count, 2)
    
    Select Case d.Count
    Case Is < 65536 'Transpose function has a limit of 65536 item to process
        
        .Value = Application.Transpose(Array(d.Keys, d.Items))
        
    Case Is <= 1048500
        
        ReDim va(1 To d.Count, 1 To 2)
        i = 0
            For Each q In d.Keys
                i = i + 1
                va(i, 1) = q: va(i, 2) = d(q)
            Next
        .Value = va
    
    Case Else
        
        MsgBox "Process is canceled, the result is more than 1048500 rows"
    
    End Select
    
    .Sort Key1:=.Cells(1, 2), Order1:=xlDescending, Key2:=.Cells(1, 1), Order2:=xlAscending, Header:=xlNo
    
End With


Cells(1, rc + 2) = n & " WORD"
Cells(1, rc + 3) = "COUNT"

End Sub

 

[wiscochris]

I'm speechless. You took my very minimally/poorly described specs and totally nailed it (and completed it on Christmas day.)
This is exactly what I was hoping for, crazy fast and very much appreciated. I'm confident others will greatly value this too. Thanks SO much!

 

[Akuini]

You're welcome, glad to help & thanks for the feedback.

 

[Akuini]

@wiscochris
I forgot to explain something:
The code will replace the stop word with "|". It means that the words that are separated by the stop word (or now by the "|") won't be considered as a phrase. For example:
Let's say "a" is a stop word. And you have a text "I buy a car".
It will change to "I buy | car", so you won't get "buy car" as a phrase. Example:

dhee - stop word try.xlsm
	A	B	C	D	E	F	G	H
1	I buy a car.	a		1 WORD	COUNT		2 WORD	COUNT
2	I buy the box.	the		buy	2		I buy	2
3				I	2
4				box	1
5				car	1
Sheet1

If you want "buy car" as a phrase then in "Sub stopWord" you need to change this part:

          tx = regEx.Replace(tx, "|")   'replace stop word with "|"

to this:

          tx = regEx.Replace(tx, " ")   'replace stop word with a space

Example:

dhee - stop word try.xlsm
	A	B	C	D	E	F	G	H	I	J	K
1	I buy a car.	a		1 WORD	COUNT		2 WORD	COUNT		3 WORD	COUNT
2	I buy the box.	the		buy	2		I buy	2		I buy box	1
3				I	2		buy box	1		I buy car	1
4				box	1		buy car	1
5				car	1
Sheet1

 

[wiscochris]

Thanks for the explanation. And that's a great addition/option.

 

[wiscochris]

Hi, I’m wondering if you would be willing to possibly help with a horizontal presentation version of the same script. This version would loop through row multiple multiple rows.

Here is a OneDrive file example of what I am hoping for. There are 2 sheets; "Original", which is your original example that includes your latest macro. The second sheet "Horizontal" is what I am hoping to get. Below is a L2BB share of that for easy reference.

kwfrequencyHorizontalSample.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X
1	Name	Text 1	Text 2	Text 3	Text 4	Text 5	1 WORD 1	COUNT	1 WORD 2	COUNT	1 WORD 3	COUNT	2 WORD 1	COUNT	2 WORD 2	COUNT	2 WORD 3	COUNT	3 WORD 1	COUNT	3 WORD 2	COUNT	3 WORD 3	COUNT
2	Chapter 1	In captivity, in the shed, Pierre had learned, not with his mind,	but with his whole being, his life, that man is created for happiness,	that happiness is within him, in the satisfying of natural human needs,	and that all unhappiness comes not from lack,	but from superfluity.	his	3	In	3	that	3	with his	2	all unhappiness	1	but from	1	all unhappiness comes	1	but from superfluity	1	but with his	1
3	Chapter 2	This black-eyed, wide-mouthed girl, not pretty but full of life	ran to hide her flushed face in the lace of her mother’s mantilla	not paying the least attention to her severe remark—and began to laugh.			her	3	to	3	not	2	attention to	1	began to	1	but full	1	attention to her	1	began to laugh	1	but full of	1
4	Chapter 3	When everything was ready, the stranger opened his eyes,	moved to the table, filled a tumbler with tea for himself and one for the beardless old man to whom he passed it."				for	2	to	2	beardless	1	beardless old	1	everything was	1	for himself	1	beardless old man	1	everything was ready	1	he passed it	1
5	Chapter 4	The proverbs, of which his talk was full, were..	those folk sayings which taken without a context seem so insignificant,	but when used appositely suddenly acquire a significance of profound wisdom.			of	2	which	2	acquire	1	appositely suddenly	1	but when	1	context seem	1	appositely suddenly acquire	1	but when used	1	context seem so	1
horizontal

The list of stop words would be on a separate sheet, stay as is in a vertical list, and apply to each loop/row individually as it does currently.

Here are some additional details to help explain the "Horizontal" sheet example:

• The example has three 1 WORD (G, I, K), 2 WORD (M, O, Q), and 3 WORD (S, U, W)columns. It would be great if I could change that from 3 to 5 or 20 or whatever, depending upon my needs.
• There are only (up to) 5 columns of text that can be entered (columns B-F). I realized that is limited vs the original script, but this is what would work for my needs.
• In the example, there are 4 entries in column A. I would like it if the script could automatically loop through all rows that exist per column A, noting that if one is blank, processing of that row can be skipped.

I would really appreciate it if you can help me with this. I really, really LOVE this script and would be thrilled if it could work as I described.

Thanks very much, in advance.