- 帖子
- 163
- 主題
- 1
- 精華
- 0
- 積分
- 170
- 點名
- 0
- 作業系統
- Window 7
- 軟體版本
- Office 2007
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2010-9-5
- 最後登錄
- 2022-7-20
|
請測試- 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
|
|
發表於 2017-2-22 14:34
| 
