Sub 最高分()
Dim x, y, i, j, k, h, m, n, a, b, c, d
Dim myth$, myf$, wb As Workbook
Dim arr(), brr(), crr(), drr As Variant
x = Cells(2, Columns.Count).End(xlToLeft).Column '最后非空列号Sheets("").
y = Cells(Cells.Rows.Count, 1).End(xlUp).Row ' 'A列最后行号
ReDim arr(1 To y, 1 To x), crr(1 To y, 1 To x) '重定数组
arr = Cells(1, 1).Offset(0, 0).Resize(y, x).Value '全部数据(行数,列数)ActiveSheet.
On Error Resume Next '错继续
Set d = CreateObject("scripting.dictionary") '创建对象
For i = 1 To UBound(arr)
If d.Exists(arr(i, 2)) Then
h = d(arr(i, 2))
If arr(i, 3) > crr(h, 3) Then '
crr(h, 2) = arr(i, 1)
crr(h, 3) = arr(i, 3)
End If
Else
k = k + 1
d(arr(i, 2)) = k
crr(k, 1) = arr(i, 2)
crr(k, 2) = arr(i, 1)
crr(k, 3) = arr(i, 3)
End If
Next i
Cells(1, 10).Offset(0, 0).Resize(k, 3) = crr
End Sub
内容全部来源于网络收集，如有侵权，请联系网站删除：QQ：24596024