同一日期+型号，获取最低价，并填入所有单元格

Sub yy()
Dim Arr, i&, x$, r%, Arr1(), aa, j&, mn
Dim d, k, t, rng As Range
Set d = CreateObject("Scripting.Dictionary")
'Sheet1.Activate
Arr = [a1].CurrentRegion
For i = 2 To UBound(Arr)
    x = Arr(i, 1) & "|" & Arr(i, 2)
    '获取同一个日期+型号所在的行号，用逗号连接起来，比如2,5,8,
    d(x) = d(x) & i & ","
Next
k = d.keys  '日期+型号的唯一值列表
t = d.items  '行号列表
For i = 0 To UBound(k)
    r = 0
    '去掉2,5,8,最后面的逗号，变成2,5,8
    t(i) = Left(t(i), Len(t(i)) - 1)
    If InStr(t(i), ",") Then
        '得到行号数组[2,5,8]
        aa = Split(t(i), ",")
        For j = 0 To UBound(aa)
            r = r + 1
            ReDim Preserve Arr1(1 To r)
            '价格数组[11,12,11]
            Arr1(r) = Arr(aa(j), 3)
            If rng Is Nothing Then
                Set rng = Cells(aa(j), 9)
            Else
                Set rng = Union(rng, Cells(aa(j), 9))
            End If
        Next
    Else
        Cells(t(i), 9) = Cells(t(i), 3).Value
    End If
    '从[11,12,11]中得到最低价格11
    mn = Application.Min(Arr1)
    '把所有同一个日期+型号的单元格都填入最低价11
    If Not rng Is Nothing Then rng = mn
    Set rng = Nothing
    'Stop  ‘测试暂停
Next
End Sub