How to determine the MAX value of a sub-group in a VBA Array

Question

MY APOLOGIES: the code snipet below can induce in error that i work from a worksheet - I got the values in the code from a worksheet only to lighten the code. The VALUES are from an ADODB dataset that is then copied to an array. The values are to stay in memory and no worksheets are to be used to get the end result. so sorry not to have specified this from the start.

I have a 2-dimensional array and I am trying to get the MAX(VALUE) for each unique IDs

ID	VALUE	DATA
101	10	1125
101	8	2546
101	11	1889
102	5	3521
102	10	2254
103	11	3544

the end result should be a finalArr with the unique IDs:

ID	VALUE	DATA
101	11	1889
102	10	2254
103	11	3544

What I have so far: I did manage to find the MAX in a specific dimension (Value)

Sub MX_Value()
    Dim dataArr, iMax As Long, iCount As Long, tmpArr() As Integer, MyDim As Integer
    Dim i As Integer

        '*NOTE: Values from worksheet is an example only
        'in real-life the data comes from an ADODB dataset
        'so i need code that works in memory only.

        dataArr = ThisWorkbook.Sheets(1).[A1:C6].Value
        ReDim tmpAr(1 To UBound(dataArr))
        MyDim = 2 'Desired Dimension, 1 to 2
        For i = 1 To UBound(dataArr)
            tmpAr(i) = dataArr(i, MyDim)
        Next
        iMax = WorksheetFunction.Max(tmpAr)
        iCount = WorksheetFunction.Match(iMax, tmpAr, 0)
        MsgBox "MAX value is in dataArr(" & iCount & ") - with data: " & dataArr(iCount, 1) & " - " & dataArr(iCount, 2) & " - " & dataArr(iCount, 3)
End Sub

but I can't figure out how to group the individual IDs to find their MAX. The only logic I can come up with would be to:

1. Get first ID, then add all rows with the same ID to a tempArr
2. Send tempArr to a Function to get the MAX and copy the MAX row to a finalArr
3. Go to next ID not matching the previous one and start again... [???]

Note: in the code example the data is from a worksheet, but only to simplify the code. In it's real-world application, the data in the array comes from an ADODB dataset - so everything must be done in memory

Any insights would be greatly appreciated!

Answer 1

Get Maximum of Each Unique Value

• The dictionary will hold the unique value as its key, and the row of the highest value as the corresponding item. While looping, it will use this item to compare the values of the 2nd column and modify it accordingly. In the end, another loop will write the results to the same array which will partially be copied to the destination range.
• One row of headers is assumed. If you don't want the headers, then change the sfcAddress if necessary and change For r = 1 to srCount and r = 0.

Option Explicit

Sub MaxOfUnique()
    
    Const sName As String = "Sheet1"
    Const sfcAddress As String = "A1"
    
    Const dName As String = "Sheet1"
    Const dfcAddress As String = "E1"
    
    Const cCount As Long = 3
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim sfCell As Range: Set sfCell = sws.Range(sfcAddress)
    Dim srg As Range
    With sfCell.CurrentRegion
        Set srg = sfCell.Resize(.Row + .Rows.Count _
            - sfCell.Row, .Column + .Columns.Count - sfCell.Column)
    End With
    Dim srCount As Long: srCount = srg.Rows.Count
    If srCount < 2 Then Exit Sub
    
    Dim Data As Variant: Data = srg.Value
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim r As Long
    
    For r = 2 To srCount
        If dict.Exists(Data(r, 1)) Then
            If Data(r, 2) > Data(dict(Data(r, 1)), 2) Then
                dict(Data(r, 1)) = r
            End If
        Else
            dict(Data(r, 1)) = r
        End If
    Next r
    
    Dim Key As Variant
    
    r = 1
    For Each Key In dict.Keys
        r = r + 1
        Data(r, 1) = Key
        Data(r, 2) = Data(dict(Key), 2)
        Data(r, 3) = Data(dict(Key), 3)
    Next Key
    
    With wb.Worksheets(dName).Range(dfcAddress).Resize(, cCount)
        .Resize(r).Value = Data ' write
        .Resize(.Worksheet.Rows.Count - .Row - r + 1).Offset(r).Clear ' below
    End With
    
End Sub