Group the cells with partially similar words

[Dheeru3193]

I have a excel sheet which contains a column with around 500 rows. I want to arrange all the cells which are having any word in common. The cells are having 2-3 words.
How can i do this.

Format is like this....

Column
Dheerendra
Dheerendra singh
Singh dheerendra
Dheerendra singh1
Dheerendra pratap singh
Dheerendra Delhi
Sumeet agarwal
Agarwal sumeet
Sumeet kumar agarwal

Then how to get the first 5 cells together one below another and the remaining ones together.

Plz help

 

[CalcSux78]

Welcome to the forum!

I'm not sure if this can easily be tackled without some VBA Coding. My apologies if this info is trivial.

• Within your workbook, press [Alt+F11] to open VBA editor.
• On the top ribbon, Select "Insert" > "Module" and you should see Module1 window appear. (This is where you'll paste the code)

IMPORTANT: For this code to work, you must add a reference to the "Microsoft Scripting Runtime."
To do so, on the ribbon, select "Tools" > "References" and select "Microsoft Scripting Runtime" from the list and press "OK"

Now we can paste the code into the Module1 window.

Option ExplicitOption Compare Text


Sub GetFrequency()
Dim Coll As New Collection
Dim var, k
Dim cel As Range
Dim aName As Variant
Dim sTemp$
Dim rng As Range
Dim dName As New Scripting.Dictionary
Dim n&, i&


'add full names to collection
    'NOTE: in next line, change the number 1 to the column number of your names
    'Example:  if your data is in column D, change the 1 to a 4
Set rng = Range(Cells(2, 1), Cells(2, 1).End(xlDown))
For Each cel In rng.Cells
    Coll.Add UCase(cel)
Next cel
'names stored, now delete range
rng = ""
'create dictionary of individual names and frequency within collection
For Each var In Coll
    sTemp = Trim(var)
    aName = Split(sTemp, " ")
    For n = LBound(aName) To UBound(aName)
        If dName.exists(aName(n)) Then
            dName(aName(n)) = dName(aName(n)) + 1
        Else
            dName.Add Key:=aName(n), Item:=1
        End If
    Next n
Next var
'sort dictionary in order of name frequency
Call SortDictionaryByItem(dName, True)


n = 1
'print results to column A
For Each k In dName.Keys
    For i = Coll.Count To 1 Step -1
        If InStr(1, Coll(i), k) > 0 Then
            rng(n, 1) = Coll(i)
            Coll.Remove i
            n = n + 1
        End If
    Next i
    dName.Remove (k)
Next k


End Sub




Sub SortDictionaryByItem(Dict As Scripting.Dictionary, Optional bDescending As Boolean)
'code modified to work with other subs
'from http://www.xl-central.com/sort-a-dictionary-by-item.html


'in calling sub, need to set the comparison mode to perform a textual comparison
'Dict.CompareMode = TextCompare


' Dictionary using Early Binding
'Set a reference to Microsoft Scripting Runtime by using
'Tools > References in the Visual Basic Editor (Alt+F11)


'Declare the variables
Dim arr() As Variant
Dim Temp1 As Variant
Dim Temp2 As Variant
Dim Txt As String
Dim i As Long
Dim j As Long


'Allocate storage space for the dynamic array
ReDim arr(0 To Dict.Count - 1, 0 To 1)


'Fill the array with the keys and items from the Dictionary
For i = 0 To Dict.Count - 1
    arr(i, 0) = Dict.Keys(i)
    arr(i, 1) = Dict.Items(i)
Next i


'Sort the array using the bubble sort method
For i = LBound(arr, 1) To UBound(arr, 1) - 1
    For j = i + 1 To UBound(arr, 1)
        If arr(i, 1) > arr(j, 1) Then
            Temp1 = arr(j, 0)
            Temp2 = arr(j, 1)
            arr(j, 0) = arr(i, 0)
            arr(j, 1) = arr(i, 1)
            arr(i, 0) = Temp1
            arr(i, 1) = Temp2
        End If
    Next j
Next i


'Clear the Dictionary
Dict.RemoveAll


'Add the sorted keys and items from the array back to the Dictionary
If bDescending = True Then
   For i = UBound(arr, 1) To LBound(arr, 1) Step -1
       Dict.Add Key:=arr(i, 0), Item:=arr(i, 1)
   Next i
Else
   For i = LBound(arr, 1) To UBound(arr, 1)
       Dict.Add Key:=arr(i, 0), Item:=arr(i, 1)
   Next i
End If
     
End Sub

Now we're ready to run the code.

You can run the code from the vba editor screen by placing your cursor within the GetFrequency Subroutine and pressing [F8].

Alternatively, you can close vba editor and run the code from excel by pressing [Alt + F8]