试试: Sub test() Dim d1 As New Dictionary, d2 As New Dictionary Dim str1 As String, i1 As Integer, i2 As Integer, arr1(), arr2() arr1 = Range("a2", [c2].End(4)).Value For i1 = 1 To UBound(arr1) str1 = arr1(i1, 1) & "|" & arr1(i1, 2) & "|" & arr1(i1, 3) If Not d1.Exists(str1) Then d1(str1) = "" If d2.Exists(arr1(i1, 1)) Then arr2 = d2(arr1(i1, 1)) i2 = UBound(arr2, 2) + 1 ReDim Preserve arr2(1 To 3, 1 To i2) Else ReDim arr2(1 To 3, 1 To 3) arr2(1, 1) = arr1(i1, 1) arr2(1, 2) = arr1(i1, 1) arr2(2, 2) = arr1(i1, 2) i2 = 3 End If arr2(1, i2) = arr1(i1, 1) arr2(2, i2) = arr1(i1, 2) arr2(3, i2) = arr1(i1, 3) d2(arr1(i1, 1)) = arr2 Erase arr2 End If Next i2 = 2 For i1 = 0 To d2.Count - 1 arr2 = Application.Transpose(d2.Items(i1)) Cells(i2, 8).Resize(UBound(arr2), 3) = arr2 i2 = i2 + UBound(arr2) Erase arr2 Next End Sub
|