12
返回列表 上一主題 發帖

[發問] 資料整理與統計

oak0723-1

帖子
222 
主題
56 
精華
0 
積分
285 
點名
0  
作業系統
window 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2010-8-30 
最後登錄
2024-4-22 

論壇贊助勳章論壇榮譽勳章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2017-2-20 18:50 | 只看該作者

[發問] 資料整理與統計

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

1216-060217-日分筆量.rar (67.18 KB)

收藏 分享

Kubi

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

  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
複製代碼

TOP

oak0723-1

帖子
222 
主題
56 
精華
0 
積分
285 
點名
0  
作業系統
window 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2010-8-30 
最後登錄
2024-4-22 

論壇贊助勳章論壇榮譽勳章
3#
發表於 2017-2-22 16:52 | 只看該作者
謝謝kubi大大你熱心幫我這個忙
只是經我測試似乎(將程式碼以按鍵趨動)
除了數據顯示位置有誤外
依編號各級距所合計與筆數似乎與我自己做的函數+手動的數聚有所差距

060222-日分筆量 - test.rar (112.03 KB)

TOP

Kubi

帖子
163 
主題
1 
精華
0 
積分
170 
點名
0  
作業系統
Window 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2010-9-5 
最後登錄
2022-7-20 
4#
發表於 2017-2-23 10:54 | 只看該作者
回復 3# oak0723-1

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

TOP

oak0723-1

帖子
222 
主題
56 
精華
0 
積分
285 
點名
0  
作業系統
window 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2010-8-30 
最後登錄
2024-4-22 

論壇贊助勳章論壇榮譽勳章
5#
發表於 2017-2-23 14:01 | 只看該作者
謝謝
小弟好好研究一下

TOP

oak0723-1

帖子
222 
主題
56 
精華
0 
積分
285 
點名
0  
作業系統
window 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2010-8-30 
最後登錄
2024-4-22 

論壇贊助勳章論壇榮譽勳章
6#
發表於 2017-2-23 19:22 | 只看該作者
謝謝kubi大大
小弟剛剛換一組數據測試
發現編號排序並非由上而下遞減排列
如何修正為由上到下遞減排列

060223-日分筆量 - test2.rar (124.1 KB)

TOP

Kubi

帖子
163 
主題
1 
精華
0 
積分
170 
點名
0  
作業系統
Window 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2010-9-5 
最後登錄
2022-7-20 
7#
發表於 2017-2-24 10:50 | 只看該作者
回復 6# oak0723-1
請測試。
060223-日分筆量 - test3.rar (130.13 KB)

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-20 
8#
發表於 2017-2-24 14:20 | 只看該作者
  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)

  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
複製代碼

TOP

oak0723-1

帖子
222 
主題
56 
精華
0 
積分
285 
點名
0  
作業系統
window 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2010-8-30 
最後登錄
2024-4-22 

論壇贊助勳章論壇榮譽勳章
9#
發表於 2017-2-25 17:14 | 只看該作者
經小弟測試後確實為正解
謝謝kubi與准提部林大大熱心解答
讓小弟獲得解答
謝謝
非常感恩
勞力!!!

TOP

oak0723-1

帖子
222 
主題
56 
精華
0 
積分
285 
點名
0  
作業系統
window 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2010-8-30 
最後登錄
2024-4-22 

論壇贊助勳章論壇榮譽勳章
10#
發表於 2017-3-15 11:47 | 只看該作者
請問若想在已標示黃底紅字之儲存格內輸入任意資料做分類,應如何做更改(如附件)

060315-日分筆量 - test1.rar (125.22 KB)

TOP

        靜思自在 : 有心就有福，有願就有力，自造福田，自得福緣。
12
返回列表 上一主題