How to reorder the entire row when grouping cells with partially similar words?

[GhostCoder]

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]

I used the above code shared by @CalcSux78 to group product names in a column with similar words. I was wondering on how it the reordering can also be expanded to include other columns in the sheet. Right now it sorts the selected column, but data in other columns remains the same so there is a mismatch. How can this code be modified to reorder the entire row?

As you can see in the attached images, only column D gets reordered.

 

[earthworm]

Kindly share VBA code

 

[GhostCoder]

Kindly share VBA code

Here's the code I used:

Option Explicit
Option 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, 4), Cells(2, 4).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