Sorting complex data in Excel - Help!

[emilyshaw93]

Hi all,

I have a list of data as follows:

	A	B	C	D	E
1	NAME	REFERENCES		NAME (Sorted)	REFERENCES (Sorted)
2	John	36, 87, JR, 11, 26		John	JR, 4, 11, 26, 36, 85, 87, 96
3	Emily	63, ES, 14, 1, 35		Emily	ES, 1, 14, 35, 63
4	Kate	KM, 73, 25, 84, 13		Kate	KM, 13, 25, 62, 73, 84, 94
5	John	85, 96, 4
6	Kate	94, 62, 25, 13

<tbody>
</tbody>

What I want to do is get the data in column B to sort into column E automatically. I want multiple data sets for John, for example, to combine, sort in ascending order, and remove duplicates (as shown in E above), automatically.

I have set up column D to sort names and remove duplicates within the list in column A already - I need a formula to do a similar thing for putting the data in column B into column E.

Any help much appreciated!

Emily

 

[MickG]

Try this if you can use this code.
Results columns "E & D"

[COLOR="Navy"]Sub[/COLOR] MG27Nov29
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range, Sp [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] i [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] j [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dic [COLOR="Navy"]As[/COLOR] Object, k [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] p [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray, w [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
 [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
   Dic.CompareMode = 1
   Range("D1:E1").Value = Array("Name", "References")
   w = 1
   [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
            [COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
            [COLOR="Navy"]End[/COLOR] If
            Sp = Split(Dn.Offset(, 1).Value, ", ")
               [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
                   Dic(Dn.Value)(Sp(n)) = Empty
                     [COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]Next[/COLOR] Dn
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
        ReDim Ray(1 To Dic(k).Count)
        c = 0
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(k): c = c + 1: Ray(c) = p: [COLOR="Navy"]Next[/COLOR] p
        [COLOR="Navy"]For[/COLOR] i = 1 To UBound(Ray)
        [COLOR="Navy"]For[/COLOR] j = i To UBound(Ray)
            [COLOR="Navy"]If[/COLOR] Val(Ray(j)) < Val(Ray(i)) [COLOR="Navy"]Then[/COLOR]
                temp = Ray(i)
                Ray(i) = Ray(j)
                Ray(j) = temp
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] j
        [COLOR="Navy"]Next[/COLOR] i
        w = w + 1
        Cells(w, "D") = k: Cells(w, "E") = Join((Ray), ",")
    [COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[RickXL]

MickG,

I liked your code so much I pinched the trick with Val().

I had formatted the numbers to add leading zeros previously but that made the alpha only strings appear last.

Looking at yours, this is a very similar approach but using stacked SortedLists instead of stacked Dictionaries.
That means that I need to check whether keys exist but it saves the separate sort step.

Sub SortData()
    Dim i  As Long, j As Long, sl As Object, ssl As Object
    Dim ele As Variant, isNew As Boolean, strCell As String
    Set sl = CreateObject("System.Collections.SortedList")
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        If sl.ContainsKey(Cells(i, "A").Value) Then isNew = False Else isNew = True
        If isNew Then Set ssl = CreateObject("System.Collections.SortedList") Else Set ssl = sl.GetByIndex(sl.IndexOfKey(Cells(i, "A").Value))
        For Each ele In Split(Cells(i, "B").Value, ", ")
            If Not ssl.ContainsKey(Val(ele)) Then ssl.Add Val(ele), ele
        Next
        If isNew Then sl.Add Cells(i, "A").Value, ssl
    Next
    For i = 0 To sl.Count - 1
        Range("D2").Offset(i) = sl.GetKey(i)
        For j = 0 To sl.GetByIndex(i).Count - 1
            If j = 0 Then strCell = sl.GetByIndex(i).GetByIndex(0) Else strCell = strCell & ", " & sl.GetByIndex(i).GetByIndex(j)
        Next
        If sl.GetByIndex(i).Count Then Range("E2").Offset(i) = strCell Else Range("E2").Offset(i) = vbNullString
    Next
End Sub

 

[RickXL]

PlanB. You can make it slightly neater by using an ArrayList as well as a SortedList. It saves two lines but the Val() trick no longer works and the alphas appear after the numbers.

Sub SortData()
    Dim i  As Long, j As Long, sl As Object, sal As Object
    Dim ele As Variant, isNew As Boolean
    Set sl = CreateObject("System.Collections.SortedList")
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        If sl.ContainsKey(Cells(i, "A").Value) Then isNew = False Else isNew = True
        If isNew Then Set sal = CreateObject("System.Collections.ArrayList") Else Set sal = sl.GetByIndex(sl.IndexOfKey(Cells(i, "A").Value))
        For Each ele In Split(Cells(i, "B").Value, ", ")
            If Not sal.Contains(ele) Then sal.Add ele
        Next
        If isNew Then sl.Add Cells(i, "A").Value, sal
    Next
    For i = 0 To sl.Count - 1
        Range("D2").Offset(i) = sl.GetKey(i)
        sl.GetByIndex(i).Sort
        Range("E2").Offset(i) = Join(sl.GetByIndex(i).ToArray, ", ")
    Next
End Sub

 

[Peter_SSs]

Rick, This is all new to me but I can see great use for some of these ideas, if I can get my head around them.

However, am I right in thinking you really need to go back to Plan A because, apart from the issue below, the Plan B code also sorts 104 before 35 for example.

... and the alphas appear after the numbers.

 

[RickXL]

Hi Peter,

It is always difficult trying to come up with a solution because not being involved with the problem you don't know how the data could change and what is important.

Initially, I pinched MickG's use of Val(). Using either a Dictionary or a SortedList permits you to sort on one value but display another. Also, I am not entirely sure how robust that is because the strings will all be sorted as zeros. They may not be sorted properly. I have not checked.

My later version uses an ArrayList because the way to convert a SortedList into a string was bugging me. If I put the Format statement back it will sort into numbers then strings but the numbers will appear as zero-filled. So, I would need to know how many digits to code for.

Here is my latest version, I sorted out the multiple "If's".:
(You can't have too many versions of a "fun" program")

Sub SortData()
    Dim i As Long, j As Long, sl As Object, sal As Object, ele As Variant
    Set sl = CreateObject("System.Collections.SortedList")
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        If sl.ContainsKey(Cells(i, "A").Value) Then Set sal = sl.GetByIndex(sl.IndexOfKey(Cells(i, "A").Value)) Else Set sal = CreateObject("System.Collections.ArrayList")
        For Each ele In Split(Cells(i, "B"), ", ")
            If Not sal.Contains(ele) Then sal.Add Format(ele, "00")
        Next
        If Not sl.ContainsKey(Cells(i, "A").Value) Then sl.Add Cells(i, "A").Value, sal
    Next
    For i = 0 To sl.Count - 1
        sl.GetByIndex(i).Sort
        Range("D2").Offset(i).Resize(1, 2) = Array(sl.GetKey(i), Join(sl.GetByIndex(i).toarray, ", "))
    Next
End Sub

While this has been fun for me I am concerned that the OP might have been wanting a worksheet formula, instead.

Regards,

 

[emilyshaw93]

Hi all, thanks for these, but I'm having issues with the name of the workbook.

I have changed the name of that sheet this morning from 'Sorted List' to 'Scraping List'.

Have changed the macro accrodingly to:
Set sl = CreateObject("System.Collections.ScrapingList")

but it says that this line needs de-bugging. Any ideas?

 

[emilyshaw93]

Hi all, thanks for these, but I'm having issues with the name of the workbook.

I have changed the name of that sheet this morning from 'Sorted List' to 'Scraping List'.

Have changed the macro accrodingly to:
Set sl = CreateObject("System.Collections.ScrapingList")

but it says that this line needs de-bugging. Any ideas?

 

[RickXL]

Hi,

You will have to leave that line as it is because it is defining the SortedList object which is used to store the names (in a list) and then sort them.

The macro should work on whatever ActiveSheet you have selected. Is that not happening?

 

[emilyshaw93]

Hi Rick,

Sorry, I have changed my spreadsheet since this post.

Columns A & B in the original post are now in a workbook called 'Initial List' and are now columns F and D respectively (their order has been reversed).
Columns D & E are now in a sheet called 'Scraping List' and are re-lettered columns B and I respectively.

Sorry I forgot to say this!