|
Option Explicit
Sub VBA()
Dim d, arr, i%, q, w, e, r, n, arr1(1 To 1000, 1 To 10000), rng
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
arr = Range("A1:B" & [b1048576].End(xlUp).Row)
For i = 3 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
d(arr(i, 1)) = arr(i, 2)
Else
d(arr(i, 1)) = d(arr(i, 1)) & "|" & arr(i, 2)
End If
Next
For q = 0 To d.Count - 1
w = Split(d.items()(q), "|")
For r = 1 To UBound(w) + 1
e = Application.Index(Split(d.items()(q), "|"), r)
n = 0
For Each rng In d.keys
n = n + 1
arr1(1, n) = rng
Next
arr1(r + 1, q + 1) = e
Next
[D2].Resize(r + 1, q + 1) = arr1
Next
Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "OK,完成!!!", 48, "温馨提示……"
End Sub
|
|