0

I was wondering if anyone can help me expand the following code to work on 6 columns. It already works pretty well for any number of rows. How do I add that same construct for columns? Username: assylias constructed this code, and I am trying to adapt it for my sorting needs.

The problem: I need to sort something like this

X A 3
X B 7
X C 2
X D 4
Y E 8
Y A 9
Y B 11
Y F 2

It needs to be sorted as follows: The column where X and Y are represent groups. The letters: A,B,C,D,E,F represent members of the group. The numbers are some metric we are comparing them by. The highest number and the associated member that earned that number is the "leader" of that group, and I want to sort the data so that each leader of each group is compared to each member of that group in the following way:

X  B A 3
X  B C 2
X  B D 4
Y  B E 8
Y  B A 9
Y  B F 2

Explanation: B happens to be the leader of both groups. I need to compare him to all the other members and to the right of their cell, have a column showing the number that they earned.

Problem: Equipped with Assylias' code, I am now attempting to expand this to my dataset. My dataset has 6 columns, so there are a bunch of qualitative columns to describe each member (like State, ID# etc), and I need help expanding the code to encompass this. Also, if somehow possible, explanations of some of the steps (maybe in form of comments) would enable me to truly connect the dots better. (Mostly, I don't understand what dict1/dict2 are and what they are doing exactly...(dict1.exists(data(i,1)) for example is not obvious to me.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
doIt
End Sub
Public Sub doIt()

Dim data As Variant
Dim result As Variant
Dim i As Long
Dim j As Long
Dim dict1 As Variant
Dim dict2 As Variant

Set dict1 = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")
data = Sheets("Sheet1").UsedRange

For i = LBound(data, 1) To UBound(data, 1)
    If dict1.exists(data(i, 1)) Then
        If dict2(data(i, 1)) < data(i, 3) Then
            dict1(data(i, 1)) = data(i, 2)
            dict2(data(i, 1)) = data(i, 3)
        End If
    Else
        dict1(data(i, 1)) = data(i, 2)
        dict2(data(i, 1)) = data(i, 3)
    End If
Next i

ReDim result(LBound(data, 1) To UBound(data, 1) - dict1.Count, 1 To 4) As Variant

j = 1
For i = LBound(data, 1) To UBound(data, 1)
    If data(i, 2) <> dict1(data(i, 1)) Then
        result(j, 1) = data(i, 1)
        result(j, 2) = dict1(data(i, 1))
        result(j, 3) = data(i, 2)
        result(j, 4) = data(i, 3)
        j = j + 1
    End If
Next i

With Sheets("Sheet2")
    .Cells(1, 5).Resize(UBound(result, 1), UBound(result, 2)) = result
End With

End Sub

Dman
  • 5
  • 4
  • I did some research and observed that "dictionary" object, utilized in this code, does not support multidimensionality. Should we re-do this as an array then? – Dman Mar 14 '12 at 02:50
  • This could be a soluion. You can find some inspiration in these threads: http://stackoverflow.com/questions/4873182/sorting-a-multidimensionnal-array-in-vba and http://stackoverflow.com/questions/152319/vba-array-sort-function – JMax Mar 14 '12 at 07:49

1 Answers1

1

I have commented the code and amended it to get the 6 columns. Now it is a quick shot so it can probably be improved, optimised etc.

Public Sub doIt()

    Dim inputData As Variant
    Dim result As Variant
    Dim thisGroup As String
    Dim thisMember As String
    Dim thisScore As String
    Dim i As Long
    Dim j As Long
    Dim membersWithHighestScore As Variant 'Will store the member with highest score for each group
    Dim highestScore As Variant 'Will store the highest score for each group

    Set membersWithHighestScore = CreateObject("Scripting.Dictionary")
    Set highestScore = CreateObject("Scripting.Dictionary")
    inputData = Sheets("Sheet1").UsedRange

    'First step: populate the dictionaries
    'At the end of the loop:
    '   - membersWithHigestScore will contain the member with the highest score for each group, for example: X=B, Y=B, ...
    '   - highestScore will contain for example: X=7, Y=11, ...
    For i = LBound(inputData, 1) To UBound(inputData, 1)
        thisGroup = inputData(i, 1) 'The group for that line (X, Y...)
        thisMember = inputData(i, 2) 'The member for that line (A, B...)
        thisScore = inputData(i, 3) 'The score for that line
        If membersWithHighestScore.exists(thisGroup) Then 'If there already is a member with a high score in that group
            If highestScore(thisGroup) < thisScore Then 'if this new line has a higher score
                membersWithHighestScore(thisGroup) = thisMember 'Replace the member with highest score for that group with the current line
                highestScore(thisGroup) = thisScore 'This is the new highest score for that group
            End If 'If the line is not a new high score, skip it
        Else 'First time we find a member of that group, it is by definition the highest score so far
            membersWithHighestScore(thisGroup) = thisMember
            highestScore(thisGroup) = thisScore
        End If
    Next i

    ReDim result(LBound(inputData, 1) To UBound(inputData, 1) - membersWithHighestScore.Count, 1 To 7) As Variant

    j = 1
    For i = LBound(inputData, 1) To UBound(inputData, 1)
        thisGroup = inputData(i, 1) 'The group for that line (X, Y...)
        thisMember = inputData(i, 2) 'The member for that line (A, B...)
        If thisMember <> membersWithHighestScore(thisGroup) Then 'If this is a line containing the highest score for that group, skip it
            result(j, 1) = thisGroup
            result(j, 2) = membersWithHighestScore(thisGroup)
            'Copy the rest of the data as is
            result(j, 3) = inputData(i, 2)
            result(j, 4) = inputData(i, 3)
            result(j, 5) = inputData(i, 4)
            result(j, 6) = inputData(i, 5)
            result(j, 7) = inputData(i, 6)
            j = j + 1
        End If
    Next i

    With Sheets("Sheet2")
        .Cells(1, 5).Resize(UBound(result, 1), UBound(result, 2)) = result
    End With

End Sub
assylias
  • 321,522
  • 82
  • 660
  • 783
  • this is a very clear and very useful code. This has completely answered my question and has provided me a platform to learn how such logic is constructed -- I thank you sincerely. – Dman Mar 15 '12 at 03:39