Frequency of Words within Cells within Range - excel

Question

I have a column of about 50 cells. Each cell contains a block of text, anywhere from 3-8 sentences.
Id like to populate a list of words being used and obtain their frequencies for the entire range (A1:A50).
Ive tried to manipulate other codes I've found in other posts but they seem to be tailored to cells that contain one word rather than multiple words.
This is the code I found that I was attempting to use.
Sub Ftable()
Dim BigString As String, I As Long, J As Long, K As Long
Dim Selection As Range
Set Selection = ThisWorkbook.Sheets("Sheet1").Columns("A")
BigString = ""
For Each r In Selection
BigString = BigString & " " & r.Value
Next r
BigString = Trim(BigString)
ary = Split(BigString, " ")
Dim cl As Collection
Set cl = New Collection
For Each a In ary
On Error Resume Next
cl.Add a, CStr(a)
Next a
For I = 1 To cl.Count
v = cl(I)
ThisWorkbook.Sheets("Sheet2").Cells(I, "B").Value = v
J = 0
For Each a In ary
If a = v Then J = J + 1
Next a
ThisWorkbook.Sheets("Sheet2").Cells(I, "C") = J
Next I
End Sub

Answer 1

Here you go, a dictionary is the best way to handle this I think as you can test if the dictionary already contains an item. Post back if there's anything you don't get.
Sub CountWords()
Dim dictionary As Object
Dim sentence() As String
Dim arrayPos As Integer
Dim lastRow, rowCounter As Long
Dim ws, destination As Worksheet
Set ws = Sheets("Put the source sheet name here")
Set destination = Sheets("Put the destination sheet name here")
rowCounter = 2
arrayPos = 0
lastRow = ws.Range("A1000000").End(xlUp).Row
Set dictionary = CreateObject("Scripting.dictionary")
For x = 2 To lastRow
sentence = Split(ws.Cells(x, 1), " ")
For y = 0 To UBound(sentence)
If Not dictionary.Exists(sentence(y)) Then
dictionary.Add sentence(y), 1
Else
dictionary.Item(sentence(y)) = dictionary.Item(sentence(y)) + 1
End If
Next y
Next x
For Each Item In dictionary
destination.Cells(rowCounter, 1) = Item
destination.Cells(rowCounter, 2) = dictionary.Item(Item)
rowCounter = rowCounter + 1
Next Item
End Sub

Answer 2

Try this (works for me with some long blocks of Lorem Ipsum text):
Sub Ftable()
Dim BigString As String, I As Long, J As Long, K As Long
Dim countRange As Range
Set countRange = ThisWorkbook.Sheets("Sheet1").Range("A1:A50")
BigString = ""
For Each r In countRange.Cells
BigString = BigString & " " & r.Value
Next r
BigString = Trim(BigString)
ary = Split(BigString, " ")
Dim cl As Collection
Set cl = New Collection
For Each a In ary
On Error Resume Next
cl.Add a, CStr(a)
Next a
For I = 1 To cl.Count
v = cl(I)
ThisWorkbook.Sheets("Sheet2").Cells(I, "B").Value = v
J = 0
For Each a In ary
If a = v Then J = J + 1
Next a
ThisWorkbook.Sheets("Sheet2").Cells(I, "C") = J
Next I
End Sub
I took it down to only looking at the 50 cells where you have data, as opposed to all >1 million in that column. I also fixed an issue where r was getting a length 1 array instead of a Range. And I renamed "Selection" to "countRange" because Selection is already defined in the application, so it was bad naming.
Also, notice that your code pulls from "Sheet1" and outputs into columns B and C of "Sheet2". Make sure you rename your worksheets or edit these values, or you'll get errors/data corruption.
This is how I'd approach the problem:
Sub Ftable()
Dim wordDict As New Dictionary
Dim r As Range
Dim countRange As Range
Dim str As Variant
Dim strArray() As String
Set countRange = ThisWorkbook.Sheets("Sheet1").Range("A1:A50")
For Each r In countRange
strArray = Split(Trim(r.Value), " ")
For Each str In strArray
str = LCase(str)
If wordDict.Exists(str) Then
wordDict(str) = wordDict(str) + 1
Else
wordDict.Add str, 1
End If
Next str
Next r
Set r = ThisWorkbook.Sheets("Sheet2").Range("B1")
For Each str In wordDict.Keys()
r.Value = str
r.Offset(0, 1).Value = wordDict(str)
Set r = r.Offset(1, 0)
Next str
Set wordDict = Nothing
End Sub
It uses a dictionary, so make sure you add a reference to the library (Tools > Add Reference > Microsoft Scripting Library). It also forces everything to lowercase - one big issue of the old code was that it failed to count capitalized and uncapitalized versions correctly, meaning it missed many words. Remove str = LCase(str) if you don't want this.
Bonus: this method ran about 8 times faster on my test sheet.