本帖最后由 cunfu2010 于 2019-1-19 00:06 编辑
Sub test()
Sheet2.UsedRange.Offset(1).ClearContents
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
x = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
arr = Sheet1.Range("A2:C" & x)
ReDim brr(1 To UBound(arr), 1 To 3)
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 1) & "," & arr(i, 3)) Then
d(arr(i, 1) & "," & arr(i, 3)) = arr(i, 2)
Else
d(arr(i, 1) & "," & arr(i, 3)) = d(arr(i, 1) & "," & arr(i, 3)) & "," & arr(i, 2)
End If
Next
For j = 0 To d.Count - 1
For k = 1 To 2
brr(j, k) = Split(d.keys()(j), ",")(k - 1)
Next
brr(j, 3) = d.items()(j)
Next
Sheet2.[D2].Resize(UBound(arr), 3) = brr
Application.ScreenUpdating = True
End Sub |