麻辣家族討論版版 » Excel程式區 » 資料整理與統計

返回列表下一主題上一主題發帖

[發問] 資料整理與統計

中學生 Rank: 2

帖子: 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)

樓主熱帖

收藏

中學生 Rank: 2

帖子: 163
主題: 1
精華: 0
積分: 170
點名: 0
作業系統: Window 7
軟體版本: Office 2007
閱讀權限: 20
性別: 男
註冊時間: 2010-9-5
最後登錄: 2022-7-20

2^#

發表於 2017-2-22 14:34 | 只看該作者

請測試

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

複製代碼

中學生 Rank: 2

帖子: 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)

中學生 Rank: 2

帖子: 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)

中學生 Rank: 2

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

論壇贊助勳章論壇榮譽勳章

5^#

發表於 2017-2-23 14:01 | 只看該作者

謝謝
小弟好好研究一下

中學生 Rank: 2

帖子: 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)

中學生 Rank: 2

帖子: 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)

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2833
主題: 10
精華: 0
積分: 2889
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-17

8^#

發表於 2017-2-24 14:20 | 只看該作者

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

複製代碼

中學生 Rank: 2

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

論壇贊助勳章論壇榮譽勳章

9^#

發表於 2017-2-25 17:14 | 只看該作者

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

中學生 Rank: 2

帖子: 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)

靜思自在 : 成功是優點的發揮，失敗是缺點的累積。

返回列表下一主題上一主題