[發問] 如何加資料

basarasy

請問大大有方法可以在同一地方把A,B,C,D 一樣資料的E加起來嗎?

Hsieh

回復 1# basarasy

1. Sub Ex()
   
2. Dim A As Range
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set d1 = CreateObject("Scripting.Dictionary")
   
5. For Each A In Range([A1], [A1].End(xlDown))
   
6. mystr = Join(Application.Transpose(Application.Transpose(A.Resize(, 4))), ",")
   
7. d(mystr) = d(mystr) + A.Offset(, 4).Value
   
8. d1(mystr) = Array(A.Value, A.Offset(, 1).Value, A.Offset(, 2).Value, A.Offset(, 3).Value, d(mystr))
   
9. Next
   
10. [H:L] = ""
    
11. [H1].Resize(d1.Count, 5) = Application.Transpose(Application.Transpose(d1.items))
    
12. End Sub

複製代碼

如果把表格加上欄名稱，就可使用樞紐分析

basarasy

回復 2# Hsieh

感謝Hsieh大大.
大大用的碼很深><,很多都沒有見過.
請問Hsieh大大可以解說嗎?

Hsieh

回復 3# basarasy
這是很直觀的代碼

1. Sub Ex()
   
2. Dim A As Range  '宣告變數為儲存格型態
   
3. Set d = CreateObject("Scripting.Dictionary")  '設置字典物件
   
4. Set d1 = CreateObject("Scripting.Dictionary")  '設置字典物件
   
5. For Each A In Range([A1], [A1].End(xlDown))  '在A欄作迴圈取得位置
   
6. mystr = Join(Application.Transpose(Application.Transpose(A.Resize(, 4))), ",")  '變數指定為A欄向右擴展成4欄大小的範圍以逗號連結的字串
   
7. d(mystr) = d(mystr) + A.Offset(, 4).Value  '計算以mystr為關鍵字的累加
   
8. d1(mystr) = Array(A.Value, A.Offset(, 1).Value, A.Offset(, 2).Value, A.Offset(, 3).Value, d(mystr))  '以mystr為關鍵字加入項目，此項目為一陣列，陣列最後一個值為累加值
   
9. Next
   
10. [H:L] = ""  '清空目標區
    
11. [H1].Resize(d1.Count, 5) = Application.Transpose(Application.Transpose(d1.items))  '將字典物件內容以2次轉置(因為要轉成標準的二維陣列)寫入目標區
    
12. End Sub

複製代碼

basarasy

回復 4# Hsieh

謝謝大大
看完大大的說明以明白少少.
因為還未學習到  設置字典物件,陣列 的用法.
還有就是  是否set做物件 的變數,最後都要set Nothing?

FAlonso

這個dictionary究竟是什麼東西? 有什麼作用? 感覺很神秘,一般vba書都未必提及

Hsieh

回復 6# FAlonso

http://forum.twbts.com/thread-20-1-1.html
http://forum.twbts.com/viewthread.php?tid=2287&extra=pageD1&page=2
這裡有初步的說明，要了解其屬性及方法請參閱VBA說明檔

asus103

回復 4# Hsieh
請問
mystr = Join(Application.Transpose(Application.Transpose(A.Resize(, 4))), ",")
程式碼中兩次Transpose的意義是否是要將1~4欄的內容巧妙的轉成陣列，而無需使用FOR迴圈，以便JOIN成一字串?

研讀超級版主的程式碼總會有令人驚艷的surprise

Hsieh

回復 6# basarasy


    釋放物件是好習慣
其實物件會隨著程序結束而自動釋放

FAlonso

1. Sub abc()
   
2. Dim myrange As Range, mystring(), count()
   
3. Dim i, j, k As Integer
   
4. Set myrange = Range("A1:D" & Range("A1").End(xlDown).Row)   '計算字母串的總範圍
   
5. i = myrange.Cells.count / 4        '計算字母串的列數
   
6. 
   
7. ReDim mystring(i)          '把mystring的array調較至字母串列數
   
8. ReDim count(i)             '每一個字母串均設有一個計數器
   
9. 
   
10. For j = 1 To i
    
11. count(j) = 1   '每個字串均出現一次,所以設計數器為1
    
12. Next
    
13. 
    
14. For j = 1 To i      
    
15. For k = 1 To 4
    
16. mystring(j) = mystring(j) + myrange.Cells(j, k)   '把字串輸入mystring
    
17. Next   '如mystring(1)是ASDF,mystring(2)是ASSS (請參考樓主excel的字母)
    
18. Next
    
19. 
    
20. For j = 1 To i - 1
    
21. For k = j + 1 To i
    
22. 
    
23. If count(j) = 0 Then
    
24. Exit For                      '計數器為0,即重覆字母刪掉,不需再檢查
    
25. End If
    
26. 
    
27. If mystring(j) = mystring(k) Then     '比較mystring array中的字母串
    
28. mystring(k) = vbnullstring   '把重覆的字母幹掉
    
29. count(j) = count(j) + 1      '相同的話,計數器加1
    
30. count(k)=0   '將重覆的字母的計數器給關掉
    
31. End If  
    
32. Next                                                
    
33. Next     
    
34. 
    
35. Range("H1").Select
    
36. For j = 1 To i
    
37. If mystring(j) <> vbNullString Then       '不是vbnullstring便抄錄在H欄
    
38. ActiveCell.Value = Cells(j, 1)
    
39. ActiveCell.Offset(, 1).Value = Cells(j, 2)
    
40. ActiveCell.Offset(, 2).Value = Cells(j, 3)
    
41. ActiveCell.Offset(, 3).Value = Cells(j, 4)
    
42. ActiveCell.Offset(, 4).Value = count(j)
    
43. ActiveCell.Offset(1).Activate
    
44. End If
    
45. Next
    
46. 
    
47. End Sub

複製代碼

希望高手評評我這個macro