麻辣家族討論版版 - Powered by Discuz! Board

Option Base 1
Sub test()
Dim d As Object
Dim arr, brr()
Set d = CreateObject("Scripting.Dictionary")
s = Array(1000, 5000, 10000, 15000, 20000, 30000, 40000, 50000, 100000, 200000, 400000, 600000, 800000, 1000000, 2000000, 3000000)
er = [A65536].End(3).Row
arr = Range("A8:C" & er)
Range("A8:C" & er).Sort key1:=[A8], Order1:=2
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
n = n + 1
d(arr(i, 1)) = n
End If
Next i
ReDim brr(d.Count, UBound(s) * 4)
[D8:D65536].ClearContents
[D8].Resize(d.Count) = Application.Transpose(d.keys)
Range("A8:C" & er) = arr
For i = 1 To UBound(arr)
For j = 2 To 3
If arr(i, j) >= 1000 Then
For a = 1 To UBound(s) - 1
If arr(i, j) >= s(a) And arr(i, j) < s(a + 1) Then
brr(d(arr(i, 1)), (a - 1) * 4 + j * 2 - 3) = brr(d(arr(i, 1)), (a - 1) * 4 + j * 2 - 3) + arr(i, j)
brr(d(arr(i, 1)), (a - 1) * 4 + j * 2 - 2) = brr(d(arr(i, 1)), (a - 1) * 4 + j * 2 - 2) + 1
Exit For
End If
Next a
End If
Next j
Next i
[E8].Resize(UBound(brr), UBound(brr, 2)) = brr
arr = ""
Set d = Nothing
Erase brr
End Sub

複製代碼

Sub test_1()
Dim xD As Object, Arr, Brr, V, N&, U%, i&, j%, k%, Km%
Set xD = CreateObject("Scripting.Dictionary")
s = Array(1, 5, 10, 15, 20, 30, 40, 50, 100, 200, 400, 600, 800, 1000, 2000, 3000, 60000)
Arr = Range("A8:C" & [A65536].End(3).Row)
ReDim Brr(1 To UBound(Arr), 1 To UBound(s) * 4 + 1)
del
For i = 1 To UBound(Arr)
V = Arr(i, 1): U = xD(V)
If U = 0 Then N = N + 1: U = N: xD(V) = N: Brr(U, 1) = V
For j = 2 To 3
Km = 0
For k = 0 To UBound(s)
If s(k) * 1000 > Arr(i, j) Then Km = (k - 1) * 4: Exit For
Next k
If Km >= 0 Then
Brr(U, Km + j * 2 - 2) = Brr(U, Km + j * 2 - 2) + Arr(i, j)
Brr(U, Km + j * 2 - 1) = Brr(U, Km + j * 2 - 1) + 1
End If
Next j
Next i
With [D8].Resize(N, UBound(s) * 4 + 1)
.Value = Brr
.Sort Key1:=.Item(1), Order1:=xlDescending, Header:=xlNo
End With
End Sub

複製代碼