求助，如何删除重复项，保留重复

Option Explicit
Sub test()
　Dim arr, dic, t, i, n
　Set dic = CreateObject("scripting.dictionary")
　arr = Range("b2:d" & [b65536].End(xlUp).Row)
　For i = 1 To UBound(arr, 1)
　　t = arr(i, 1) & "|" & arr(i, 2)
　　If Not dic.exists(t) Then
　　　dic.Add t, arr(i, 3)
　　Else
　　　If Val(dic(t)) < Val(arr(i, 3)) Then dic(t) = arr(i, 3)
　　End If
　Next
　[g:i].ClearContents
　If dic.Count = 0 Then Exit Sub
　ReDim arr(1 To dic.Count, 1 To 3)
　For Each t In dic.keys
　　n = n + 1: arr(n, 1) = Split(t, "|")(0)
　　arr(n, 2) = Split(t, "|")(1): arr(n, 3) = dic(t)
　Next
　[g2].Resize(UBound(arr, 1), 3) = arr
End Sub