­ã´£³¡ªL

Sub ¤ÀÃþ²Î­p()
Dim xD, xR As Range, Arr, Brr, i&, j%, Jm&, T, N&, C&(1 To 4)
Sheets("²Î­p").UsedRange.Offset(1, 0).EntireRow.Delete
Arr = Range([¸ê®Æ!A2], [¸ê®Æ!A65536].End(xlUp)(1, 5))
ReDim Brr(1 To UBound(Arr), 1 To 12)
Set xD = CreateObject("Scripting.Dictionary")
¡@
For i = 1 To UBound(Arr)
¡@¡@T = 0
For j = 1 To 4
¡@¡@T = T * IIf(j = 4, 100, 10) + Arr(i, j + 1)
¡@¡@Jm = xD(T)
¡@¡@If Jm = 0 Then C(j) = C(j) + 1: Jm = C(j): xD(T) = Jm
¡@¡@If Jm > N Then N = Jm
¡@¡@Brr(Jm, 12 - j * 3 + 1) = T
¡@¡@Brr(Jm, 12 - j * 3 + 2) = Brr(Jm, 12 - j * 3 + 2) + Arr(i, 1)
¡@¡@Brr(Jm, 12 - j * 3 + 3) = Brr(Jm, 12 - j * 3 + 3) + 1
Next j:  Next i
¡@
Set xR = [²Î­p!A2]
xR.Resize(N, 12) = Brr
For j = 1 To 4
¡@¡@xR.Resize(N, 3).Sort Key1:=xR, Order1:=xlAscending, Header:=xlNo
¡@¡@Set xR = xR(1, 4)
Next j
End Sub

°Ñ¦Òªþ¥ó¡G
¤ÀÃþ²Î­pv01.rar (15.77 KB)

¤U¸ü¦¸¼Æ: 30

2015-12-12 11:48

¡@