Thread: Extract the most common words taken N at a time

I have a single column where each cell contains multiple words in any order.

I need to find which group of N words in a cell exist in the greatest number of rows (or cells for this 1-column case).

Example: (using letters for simplicity)
In the data below, each row of letters is one cell.

I want to determine which 3 letters in a cell exist in the greatest number of cells?
I believe B, E, and F (rows 1, 3 and last row).
Edit: (also B, F, H in rows 1, 4 and last row - discovered later)

F H E B A
D B A G
E B A F C
B H C F
C G D
D F A H
G E F D
C B H D A
B H F E D

Like this example, each cell contains only a few words (maybe 10 max), but there are many different words and hundreds of rows, however all the words could be extracted and individually listed if necessary, e.g. used in a lookup table, separate array, etc.

Any insights appreciated!

Hi Aldrin,

Try looking at Advanced Filter feature of Excel with wildcard usage. Thanks.

Regards,
DILIPandey

<click on below 'star' if this helps>

Hi

I have probably made this far more complex and ugly than it needs to be, but it seems to work. The trick seems to be to eliminate words that appear infrequently to reduce the word list to a manageable level. If all words occur with about the same frequency this will not work.

You need to have your source words in a worksheet named "source" and a separate blank sheet in the workbook called "words" to list and manipulate data.

the macros should run in the order listed (or the macro a_all_macros will run them for you):

a_words_list
copies each word in the cells in sheet "source" to a separate row in sheet "words"

b_sort_words
sorts them alphabetically

c_count_frequencies
counts the frequencies with which each word occurs

d_delete_duplicates
deletes all words that occur only once (these can't be the most frequent) and all duplicates, leaving just one instance of each word in the list

e_sort_by_frequency
sorts the remaining words by descending order of frequency

f_find_most_frequent_delete_others
for the top 3 most frequent words, counts the number of occasions on which all three words occur in one cell in sheet "source". Deletes all words that occur less frequently than this (they cannot be in the most frequent 3)

hopefully, this will reduce the list of words to a manageable length (20 or less words). Otherwise, it will probably not work.

g_check_nos
If so, the final macro determines all permutations of 3 words in the list and checks their frequency in sheet “source”, returning the most frequent

Sub a_all_macros()
a_words_list
b_sort_words
c_count_frequencies
d_delete_duplicates
e_sort_by_frequency
f_find_most_frequent_delete_others
g_check_nos
End Sub

Sub a_words_list()
Dim arnos As Variant, n As Long, sn As Long, MyWord As Variant
Sheets("words").Range("A1:b1").EntireColumn.Delete
sn = 1
For Each cell In Sheets("source").UsedRange
    arrNos = Split(cell.Value, " ")
    For n = LBound(arrNos) To UBound(arrNos)
        MyWord = LCase(Trim(arrNos(n)))
        If Len(MyWord) > 0 Then
            Sheets("words").Columns(1).Rows(sn).Value = MyWord
            sn = 1 + sn
        End If
        Next n
Next cell
Sheets("words").Select
'sort_and_delete_duplicates
End Sub
Sub b_sort_words()
Dim LastRow As Long, SortRange, wn As Long
LastRow = Sheets("words").Cells(Rows.Count, 1).End(xlUp).Row
SortRange = Range("A1", Columns(1).Rows(LastRow).Address).Address
Range(SortRange).Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End Sub
Sub c_count_frequencies()
Dim LastRow As Long, SortRange, wn As Long, az As Long
LastRow = Sheets("words").Cells(Rows.Count, 1).End(xlUp).Row
SortRange = Range("A1", Columns(1).Rows(LastRow).Address).Address
For az = 1 To LastRow
    'Sheets("words").Columns(2).Rows(az).Formula = "=countif(" & SortRange & ",A" & az & ")"
    Sheets("words").Columns(2).Rows(az).Value = Application.WorksheetFunction.CountIf(Range("A1", Columns(1).Rows(LastRow).Address), Sheets("words").Columns(1).Rows(az).Value)
Next az

End Sub
Sub d_delete_duplicates()
Dim LastRow As Long, qwn As Long

LastRow = Sheets("words").Cells(Rows.Count, 1).End(xlUp).Row
Application.EnableCancelKey = xlDisabled

'delete singletons
For qwn = LastRow To 1 Step -1
    If Sheets("words").Columns(2).Rows(qwn).Value = 1 Then Sheets("words").Rows(qwn).EntireRow.Delete
Next qwn
    

'delete duplicates
LastRow = Sheets("words").Cells(Rows.Count, 1).End(xlUp).Row
For qwn = LastRow To 2 Step -1
    If Sheets("words").Columns(1).Rows(qwn).Value = Sheets("words").Columns(1).Rows(qwn - 1).Value Then Sheets("words").Columns(1).Rows(qwn).EntireRow.Delete
Next qwn
Application.EnableCancelKey = xlenabled
End Sub
Sub e_sort_by_frequency()
Dim LastRow As Long, SortRange, wn As Long
LastRow = Sheets("words").Cells(Rows.Count, 1).End(xlUp).Row
SortRange = Range("A1", Columns(2).Rows(LastRow).Address).Address
Range(SortRange).Sort Key1:=Range("b1"), Order1:=xlDescending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End Sub

Sub f_find_most_frequent_delete_others()
Dim LastRow As Long, stp As Boolean, arnos As Variant, n As Long, MyWord As Variant, sn As Long
LastRow = Sheets("words").Cells(Rows.Count, 1).End(xlUp).Row

MaxNo = 0
txt = ""
For Z = 1 To 10
    Word1 = Sheets("words").Columns(1).Cells(1).Value
    word2 = Sheets("words").Columns(1).Cells(Z + 1).Value
    word3 = Sheets("words").Columns(1).Cells(Z + 2).Value
        
fn = 0
    
For Each cell In Sheets("source").UsedRange
    tc1 = 0
    tc2 = 0
    tc3 = 0
    arrNos = Split(cell.Value, " ")
    For n = LBound(arrNos) To UBound(arrNos)
        
        MyWord = LCase(Trim(arrNos(n)))
        
        If Len(MyWord) > 0 Then
            If MyWord = Word1 Then tc1 = tc1 + 1
            If MyWord = word2 Then tc2 = tc2 + 1
            If MyWord = word3 Then tc3 = tc3 + 1
            End If
            
        Next n
        If tc1 > 0 And tc2 > 0 And tc3 > 0 Then fn = fn + 1
Next cell


'Delete words with lower frequency
Application.EnableCancelKey = xlDisabled
'delete singletons
For qwn = LastRow To 1 Step -1
    If Sheets("words").Columns(2).Rows(qwn).Value < fn Then Sheets("words").Rows(qwn).EntireRow.Delete
Next qwn
Application.EnableCancelKey = xlenabled
If fn > MaxNo Then
    MaxNo = fn
    txt = Word1 & " " & word2 & " " & word3
End If
Next Z

End Sub
Sub g_check_nos()
Dim LastRow As Long, aa As Long, bb As Long, cc As Long, fn As Long, MaxNo As Long, txt As String, res As Long
LastRow = Sheets("words").Cells(Rows.Count, 1).End(xlUp).Row
If LastRow > 20 Then res = MsgBox("the list contains more than 20 words and will take a long time to process, are you sure you wish to proceed?", 4)
If res = 7 Then End

MaxNo = 0

For aa = 1 To LastRow
    Word1 = Sheets("words").Columns(1).Rows(aa).Value
    For bb = aa + 1 To LastRow
        word2 = Sheets("words").Columns(1).Rows(bb).Value
        For cc = bb + 1 To LastRow
            word3 = Sheets("words").Columns(1).Rows(cc).Value
            fn = 0
    
            For Each cell In Sheets("source").UsedRange
                tc1 = 0
                tc2 = 0
                tc3 = 0
            arrNos = Split(cell.Value, " ")
            For n = LBound(arrNos) To UBound(arrNos)
                MyWord = LCase(Trim(arrNos(n)))
                If Len(MyWord) > 0 Then
                    If MyWord = Word1 Then tc1 = tc1 + 1
                    If MyWord = word2 Then tc2 = tc2 + 1
                    If MyWord = word3 Then tc3 = tc3 + 1
                End If
            Next n
        If tc1 > 0 And tc2 > 0 And tc3 > 0 Then fn = fn + 1
        If fn > MaxNo Then
            MaxNo = fn
            txt = Word1 & ", " & word2 & ", " & word3
        End If
        
Next cell
        Next cc
    Next bb
Next aa

MsgBox "these three words occur in " & MaxNo & " cells: " & txt
End Sub

Hi

Slightly different approach. This will allow you to nominate the number of words in your groupings. I've only programmed for 3 and 4 word combinations just so you get the idea.

I've also hard coded the range to process - again just to give you an idea. This can be automated, but the output will have to be put into a different place.

Sub aaa()
  Dim dic As Object
  Set dic = CreateObject("Scripting.dictionary")
  'nominate the number of words in the group
  wordcnt = 4
  Set srchrng = Range("A1:A9")
  
  Range("E:I").ClearContents
  For Each ce In srchrng
    arr = Split(ce, " ")
    For i = LBound(arr) To UBound(arr)
      If Not dic.exists(arr(i)) Then
        dic.Add Item:=1, Key:=arr(i)
      Else
        dic(arr(i)) = dic(arr(i)) + 1
      End If
    Next i
  
  
  Next ce
  
  For Each ce In dic
    outrow = Cells(Rows.Count, "E").End(xlUp).Offset(1, 0).Row
    Cells(outrow, "E").Value = ce
    Cells(outrow, "F").Value = dic(ce)
  Next ce
  
  Range("E:F").Sort Key1:=Range("F1"), Order1:=xlDescending, Header:=xlNo
  
  'build work groups
  
  Select Case wordcnt
    Case 3
      x = Cells(Rows.Count, "E").End(xlUp).Row
      For i = 1 To x - 2
        For j = i + 1 To x - 1
          For k = j + 2 To x
            Cells(Rows.Count, "H").End(xlUp).Offset(1, 0).Value = Cells(i, "E") & " " & Cells(j, "E") & " " & Cells(k, "E")
          Next k
        Next j
      Next i
      
    Case 4
      x = Cells(Rows.Count, "E").End(xlUp).Row
      For i = 1 To x - 3
        For j = i + 1 To x - 2
          For k = j + 1 To x - 1
            For l = k + 1 To x
              Cells(Rows.Count, "H").End(xlUp).Offset(1, 0).Value = Cells(i, "E") & " " & Cells(j, "E") & " " & Cells(k, "E") & " " & Cells(l, "E")
            Next l
          Next k
        Next j
      Next i
    
  End Select
  'process word groups

  For Each ce In Range("H2:H" & Cells(Rows.Count, "H").End(xlUp).Row)
    appearcnt = 0
    For Each ce2 In srchrng
      foundit = True
      wordarr = Split(ce, " ")
      For i = LBound(wordarr) To UBound(wordarr)
        If InStr(1, ce2, wordarr(i)) = 0 Then foundit = False
      Next i
      If foundit Then appearcnt = appearcnt + 1
    Next ce2
    ce.Offset(0, 1).Value = appearcnt
  Next ce
  
End Sub

Using the above for a 3 word group, I noticed that F, B and H also have 3 rows...

rylo