求同一ID下最大值

shi353

Sub test1()
Dim A()
Set d = CreateObject("Scripting.Dictionary")
Sheet1.Activate
arr = [a1].CurrentRegion
For i = 2 To UBound(arr)
    If Not d.exists(arr(i, 1)) Then
    ReDim A(1 To 1): A(1) = arr(i, 2): d(arr(i, 1)) = A
    Else
        A = d(arr(i, 1)): ReDim Preserve A(1 To UBound(A) + 1)
        A(UBound(A)) = arr(i, 2)
        BubbleSort A
        d(arr(i, 1)) = A
    End If
Next
'-----------------------------------------
Erase A
Set B = Range([A2], [A65536].End(3))
For i = 1 To B.Cells.Count
    Set s = B.Cells(i)
    A = d(s.Value)
    If UBound(A) = 1 Then GoTo J
    If UBound(A) > 1 And s.Offset(, 1) = A(UBound(A)) Then s.Offset(, 3) = "Max"
    If UBound(A) > 1 And s.Offset(, 1) = A(1) Then s.Offset(, 3) = "Min"
J:
Next
End Sub

Sub BubbleSort(list)    'Only use 1D array Number sort
'   Sorts an array using bubble sort algorithm
    Dim First As Integer, Last As Long
    Dim i As Long, J As Long
    Dim Temp As Long
    First = LBound(list)
    Last = UBound(list)
    For i = First To Last - 1
        For J = i + 1 To Last
            If list(i) > list(J) Then
                Temp = list(J)
                list(J) = list(i)
                list(i) = Temp
            End If
        Next J
    Next i
End Sub