根据条件去重后将内容用逗号隔开

一把小刀闯天下

'数据量大换快排，，，

Option Explicit

Sub test()
  Dim arr, i, m, t
  arr = [a1].CurrentRegion.Offset(1)
  Call bsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 1)
  For i = 1 To UBound(arr, 1) - 1
    If InStr(t, "," & arr(i, 2) & "|") = 0 Then t = t & "," & arr(i, 2) & "|"
    If arr(i, 1) <> arr(i + 1, 1) Then
      m = m + 1: arr(m, 1) = arr(i, 1)
      arr(m, 2) = Replace(Mid(t, 2), "|", vbNullString)
      t = vbNullString
    End If
  Next
  [d2].Resize(m, 2) = arr
End Sub

Function bsort(arr, first, last, left, right, key)
  Dim i, j, k, t
  For i = first To last - 1
    For j = first To last + first - 1 - i
      If arr(j, key) > arr(j + 1, key) Then
        For k = left To right
          t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
        Next
      End If
  Next j, i
End Function

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, m, t, p
  arr = [a1].CurrentRegion.Offset(1)
  For i = 1 To UBound(arr, 1) - 1: arr(i, 3) = i: Next
  Call bsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 1)
  p = 1
  For i = 1 To UBound(arr, 1) - 1
    If InStr(t, "," & arr(i, 2) & "|") = 0 Then t = t & "," & arr(i, 2) & "|"
    If arr(i, 1) <> arr(i + 1, 1) Then
      m = m + 1: arr(m, 1) = arr(i, 1)
      arr(m, 2) = Replace(Mid(t, 2), "|", vbNullString)
      arr(m, 3) = arr(p, 3): p = i + 1
      t = vbNullString
    End If
  Next
  Call bsort(arr, 1, m, 1, UBound(arr, 2), 3)
  [d2].Resize(m, 2) = arr
End Sub

Function bsort(arr, first, last, left, right, key)
  Dim i, j, k, t
  For i = first To last - 1
    For j = first To last + first - 1 - i
      If arr(j, key) > arr(j + 1, key) Then
        For k = left To right
          t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
        Next
      End If
  Next j, i
End Function