Sub TimMax()Dim Arr(), ArrKQ(), MaxS
Dim i As Long, j As Long, s As Long
Arr = Sheet1.Range("A4:B" & Sheet1.[B65000].End(3).Row + 1).Value
ReDim ArrKQ(1 To UBound(Arr), 1 To 1)
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
If Arr(i, 1) <> "" And Not Dic.Exists(Arr(i, 1)) Then
s = s + 1
Dic.Add Arr(i, 1), ""
MaxS = Arr(i, 2)
For j = i To i + 100
If Arr(j, 1) <> Arr(i, 1) Or m = UBound(Arr) Then GoTo NextI
If Arr(j, 2) > MaxS Then
MaxS = Arr(j, 2)
End If
Next
NextI:
ArrKQ(s, 1) = MaxS
End If
Next
Sheet1.Range("C4").Resize(s).Value = ArrKQ
End Sub
