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

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

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!

CodePudding user response：

You can use a dictionary to keep track of the maximum values, see example below.

This is the class module called "Record"

Public id As Integer
Public value As Integer
Public data As Integer

Here's the code for the button click I wired up on the sheet

Sub Button3_Click()
    Dim dict                   'Create a variable
    Set dict = CreateObject("Scripting.Dictionary")
    
    Dim dataArr() As Variant
    Dim id, value, data As Integer
    dataArr = Range("A2:C7").value
    Dim rec As Record
    
    For i = 1 To UBound(dataArr)
        id = dataArr(i, 1)
        value = dataArr(i, 2)
        data = dataArr(i, 3)
        
        If (dict.Exists(id)) Then
            Set rec = dict(id)
            ' if value is greater, then update it in dictionary for this id
            If (value > rec.value) Then
                dict.Remove (rec.id)
                Set rec = New Record
                rec.id = id
                rec.value = value
                rec.data = data
                dict.Add id, rec
            End If
        Else
            ' this is an id we haven't seen before, so add rec to dictionary
            Set rec = New Record
            rec.id = id
            rec.value = value
            rec.data = data
            dict.Add id, rec
        End If
    Next
    
    ' print results
    Dim result As String
    For Each id In dict.Keys()
        Set rec = dict(id)
        result = result & "id = " & id & ", maxValue = " & rec.value & ", data = " & rec.data & vbCrLf
    Next
    
    MsgBox (result)
    
End Sub

CodePudding user response：

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