使用VBA求資料統計輸出

b9208

各位先進前輩
請教如何設計VBA程式來執行。
計算〞資料表〞內地區及姓名相同之次數，並輸出於〞統計表〞中。
非常感謝協助
H1.rar (3.11 KB)

下載次數: 14

2011-2-24 00:07

hugh0620

回復 1# b9208


    寫得很爛~ 但還是可以依你設的條件完成~
    版主大大會有更好的寫法  我的寫法是初學者的寫法唷~ 僅供參考

    H1_統計.rar (15.03 KB)

下載次數: 11

2011-2-24 09:41

b9208

回復 2# hugh0620

H2.rar (14.83 KB)

下載次數: 5

2011-2-24 10:50

謝謝前輩指導
目前測試OK
另請教如下條件：
一、【輸出小計】：只輸出台北、屏東、新竹地區 (D3:F3)
二、【輸出合計】：輸出所有地區
請參閱統計表
Thanks

Hsieh

回復 3# b9208
附件內樞紐分析表方法供你參考 H1_統計.rar (16.29 KB)

下載次數: 29

2011-2-24 12:02

1. Private Sub CommandButton1_Click()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. Set d1 = CreateObject("Scripting.Dictionary")
   
4. Set d2 = CreateObject("Scripting.Dictionary")
   
5. With Sheet3
   
6.    For Each a In .Range(.[B6], .[B65536].End(xlUp))
   
7.       ar = Array(a, a.Offset(, 2), a.Offset(, 3), "")
   
8.       d(a.Offset(, 3).Value) = d(a.Offset(, 3).Value) + 1
   
9.       ar(3) = d(a.Offset(, 3).Value)
   
10.       d1(a.Offset(, 3).Value) = ar
    
11.       d2(a.Value) = d2(a.Value) + 1
    
12.     Next
    
13. End With
    
14. With Sheets("統計表")
    
15. .[B7:F65536] = ""
    
16. .[B7].Resize(d1.Count, 4) = Application.Transpose(Application.Transpose(d1.items))
    
17. .[B6].Resize(d1.Count + 1, 4).Sort key1:=.[B7], key2:=.[C7], header:=xlYes
    
18. .[G7:H65536] = ""
    
19. .[G7].Resize(d2.Count, 1) = Application.Transpose(d2.keys)
    
20. .[H7].Resize(d2.Count, 1) = Application.Transpose(d2.items)
    
21. .[G6].Resize(d2.Count + 1, 2).Sort key1:=.[G7], header:=xlYes
    
22. .Select
    
23. End With
    
24. End Sub

複製代碼

b9208

回復 4# Hsieh
謝謝版主
程式測試可以
樞紐分析表方法目前學習中

aa7551

版主,請教With Sheet3    For Each a In .Range(.[B6], .[B65536].End(xlUp))..... End With
sheet的順序應為:統計表,資料表,樞紐分析表,在此時使用sheet3,不是應為樞紐分析表嗎?請解答迷津

b9208

回復 6# aa7551

請進入〞程式檢視碼〞查看
sheet2 (統計表)
sheet3 (資料表)
sheet 4 (樞紐分析表)
不一定第一個工作表就是sheet1

Hsieh

回復 6# aa7551


    Sheet3是資料表的CodeName

下載 (10.01 KB)

2011-2-26 18:32

aa7551

學習了,以前總認為是工作表的排列順序為主,受教了,謝謝

GBKEE

回復 6# aa7551

1. Sub Ex()
   
2. Dim i As Integer
   
3. For i = 1 To Sheets.Count
   
4.     MsgBox Sheets(i).Name
   
5. Next
   
6. End Sub

複製代碼

如圖:

下載 (9.52 KB)

2011-2-27 14:49