[發問] 資料整理與統計

oak0723-1

如附件
綠色標籤活頁是我一半利用函數一半用人工所做成
若要利用VB做成標籤名稱為"分筆量"活頁
要如何才能達成

Kubi

請測試

1. Option Base 1
   
2. 
   
3. Sub test()
   
4.     Dim d As Object
   
5.     Dim arr, brr()
   
6.     Set d = CreateObject("Scripting.Dictionary")
   
7.     s = Array(1000, 5000, 10000, 15000, 20000, 30000, 40000, 50000, 100000, 200000, 400000, 600000, 800000, 1000000, 2000000, 3000000)
   
8.     er = [A65536].End(3).Row
   
9.     arr = Range("A8:C" & er)
   
10.     Range("A8:C" & er).Sort key1:=[A8], Order1:=2
    
11.     For i = 1 To UBound(arr)
    
12.         If Not d.exists(arr(i, 1)) Then
    
13.             n = n + 1
    
14.             d(arr(i, 1)) = n
    
15.         End If
    
16.     Next i
    
17.     ReDim brr(d.Count, UBound(s) * 4)
    
18.     [D8:D65536].ClearContents
    
19.     [D8].Resize(d.Count) = Application.Transpose(d.keys)
    
20.     Range("A8:C" & er) = arr
    
21.     For i = 1 To UBound(arr)
    
22.         For j = 2 To 3
    
23.             If arr(i, j) >= 1000 Then
    
24.                 For a = 1 To UBound(s) - 1
    
25.                     If arr(i, j) >= s(a) And arr(i, j) < s(a + 1) Then
    
26.                         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)
    
27.                         brr(d(arr(i, 1)), (a - 1) * 4 + j * 2 - 2) = brr(d(arr(i, 1)), (a - 1) * 4 + j * 2 - 2) + 1
    
28.                         Exit For
    
29.                     End If
    
30.                 Next a
    
31.             End If
    
32.         Next j
    
33.     Next i
    
34.     [E8].Resize(UBound(brr), UBound(brr, 2)) = brr
    
35.     arr = ""
    
36.     Set d = Nothing
    
37.     Erase brr
    
38. End Sub

複製代碼

oak0723-1

謝謝kubi大大你熱心幫我這個忙
只是經我測試似乎(將程式碼以按鍵趨動)
除了數據顯示位置有誤外
依編號各級距所合計與筆數似乎與我自己做的函數+手動的數聚有所差距

Kubi

回復 3# oak0723-1

你的程式碼放錯模組，不應該放在工作表模組，應該放在一般模組內，請參考附加檔案。
請執行 [資料分筆] 按鈕。
060222-日分筆量 - test1.rar (119.12 KB)

下載次數: 7

2017-2-23 10:54

oak0723-1

謝謝
小弟好好研究一下

oak0723-1

謝謝kubi大大
小弟剛剛換一組數據測試
發現編號排序並非由上而下遞減排列
如何修正為由上到下遞減排列

Kubi

回復 6# oak0723-1
請測試。
060223-日分筆量 - test3.rar (130.13 KB)

下載次數: 21

2017-2-24 10:50

准提部林

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

複製代碼

oak0723-1

經小弟測試後確實為正解
謝謝kubi與准提部林大大熱心解答
讓小弟獲得解答
謝謝
非常感恩
勞力!!!

oak0723-1

請問若想在已標示黃底紅字之儲存格內輸入任意資料做分類,應如何做更改(如附件)