Count 2- and 3-word strings frequency in Excel - excel

Question

Hello smart human beings out there
I have this setup in my Excel
Basically, what I'm trying to achieve here is automatically grab every single string from column A (and paste to column H) and return the frequency in column I. The script is below
Sub WordCountTester()
Dim d As Object, k, i As Long, ws As Worksheet
Set ws = ActiveSheet
With ws.ListObjects("Table3")
If Not .DataBodyRange Is Nothing Then
.DataBodyRange.Delete
End If
End With
Set d = WordCounts(ws.Range("A2:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row), _
ws.Range("F2:F" & ws.Cells(Rows.Count, "F").End(xlUp).Row))
'list words and frequencies
For Each k In d.keys
ws.Range("H2").Resize(1, 2).Offset(i, 0).Value = Array(k, d(k))
i = i + 1
Next k
End Sub
'rngTexts = range with text to be word-counted, defined in set d= above
'rngExclude = 'range with words to exclude from count, defined in set d= above
Public Function WordCounts(rngTexts As Range, rngExclude As Range) As Object 'dictionary
Dim words, c As Range, dict As Object, regexp As Object, w, wd As String, m
Set dict = CreateObject("scripting.dictionary")
Set regexp = CreateObject("VBScript.RegExp") 'see link below for reference
With regexp
.Global = True
.MultiLine = True
.ignorecase = True
.Pattern = "[\dA-Z-]{3,}" 'at least 3 characters
End With
'loop over input range
For Each c In rngTexts.Cells
If Len(c.Value) > 0 Then
Set words = regexp.Execute(LCase(c.Value))
'loop over matches
For Each w In words
wd = w.Value 'the text of the match
If Len(wd) > 1 Then 'EDIT: ignore single characters
'increment count if the word is not found in the "excluded" range
If IsError(Application.Match(wd, rngExclude, 0)) Then
dict(wd) = dict(wd) + 1
End If
End If '>1 char
Next w
End If
Next c
Set WordCounts = dict
End Function
However, it currently count the string with 1 word only. I want to count strings with 2 and 3 words (and I will consider drive-by as 2 words). Can someone please tell me where in this code I have to fix to achieve that? I still want to keep column F there because there can be 2- or 3- word strings that I want to exclude. Thanks!

Answer 1

If you changed your mind and consider that also two words pairs 2-3, 4-5, 6-7 and so on are necessary, please test the next solution:
Private Sub WordPairsCountTester()
Dim d As Object, k, i As Long, ws As Worksheet, arrFin
Set ws = ActiveSheet
'Attention, please! The last parameter of the called function means How Many Consecutive Words to be counted
Set d = WordPairCountsSp(ws.Range("A2:A" & ws.cells(rows.count, "A").End(xlUp).row), _
ws.Range("F2:F" & ws.cells(rows.count, "F").End(xlUp).row), 3)
arrFin = Application.Transpose(Array(d.Keys, d.items)) 'place the dictionary in an array
'clear contents of the columns where a previous result was returned, if any...:
ws.Range("H2:I" & ws.Range("H" & ws.rows.count).End(xlUp).row).ClearContents
ws.Range("H2").Resize(UBound(arrFin), 2).Value = arrFin 'drop the array content at once
End Sub
Private Function WordPairCountsSp(rngTexts As Range, rngExclude As Range, nrNeigh As Long) As Object
Dim dict As Object, arr, arrCell, i As Long, pairWd As String, j As Long, k As Long
arr = rngTexts.Value 'place the range in an array for faster iteration
Set dict = CreateObject("scripting.dictionary")
For i = 1 To UBound(arr) 'iterate between the array elements
arrCell = Split(Replace(Replace(Replace(Replace(arr(i, 1), ",", ""), ".", ""), "?", ""), "!", "")) 'split the string by default delimiter (space)
If UBound(arrCell) + 1 >= nrNeigh Then
For j = 0 To UBound(arrCell) - nrNeigh + 1 'iterate between the array elements
pairWd = arrCell(j)
For k = 1 To nrNeigh - 1
pairWd = pairWd & " " & arrCell(j + k) 'create a string from nrNeigh neighbour words
Next k
If IsError(Application.match(pairWd, rngExclude, 0)) Then
dict(pairWd) = dict(pairWd) + 1 'place the unique pairs as keys and add occurrences as items
End If
Next j
End If
Next i
Set WordPairCountsSp = dict 'return the above created dictionary
End Function