'结果对不上,,,
Option Explicit
Sub test()
Dim arr, i, dic, t
Set dic = CreateObject("scripting.dictionary")
arr = Range("d2:k" & [d2].End(xlDown).Row)
For i = 1 To UBound(arr, 1)
dic(arr(i, 1)) = dic(arr(i, 1)) & "、" & arr(i, 8)
Next
For Each i In dic.keys
dic(i) = dic(i) & "、"
Next
For i = 1 To UBound(arr, 1)
t = Split(dic(arr(i, 1)), "、")
If UBound(t) > 2 Then
arr(i, 1) = "与" & Mid(Replace(dic(arr(i, 1)), "、" & arr(i, 8) & "、", "、"), 2)
arr(i, 1) = Left(arr(i, 1), Len(arr(i, 1)) - 1) & "重复"
Else
arr(i, 1) = vbNullString
End If
Next
[m2].Resize(UBound(arr, 1)) = arr
End Sub |