[發問] 請教分欄排列:有無更快的寫法

mpegwmvavi

想請問各位如何讓下面的巨集跑得更快(第二個部分)
假設我在A欄,B欄各有50000列自然數,
C欄=A欄+B欄,
D欄=種類

C欄我嘗試了下面三種寫法
分別是:
1.直接用cell相加
2.用工作表函數
3.用字典
方法1耗費2秒
方法2耗費3秒,
用字典則是0秒
毫無疑問的用字典最快

代碼如下

1. Public Sub 兩欄相加1()
   
2. Start = Timer    '計時開始
   
3. 
   
4. With ActiveSheet
   
5.     For i = 1 To 50000
   
6.         .Cells(i, 3) = .Cells(i, 1) + .Cells(i, 2)
   
7.     Next
   
8. End With
   
9. 
   
10. MsgBox "Completion in  " & Format((Timer - Start) / 86400, "hh:mm:ss")   '計時結束
    
11. ===================
    
12. Public Sub 兩欄相加2()
    
13. Start = Timer    '計時開始
    
14. 
    
15. With ActiveSheet
    
16.     For i = 1 To 50000
    
17.         .Cells(i, 3) = Application.WorksheetFunction.Sum(.Cells(i, 1), .Cells(i, 2))
    
18.     Next
    
19. End With
    
20. 
    
21. MsgBox "Completion in  " & Format((Timer - Start) / 86400, "hh:mm:ss")   '計時結束 Sub
    
22. End Sub
    
23. ===============
    
24. Public Sub 兩欄相加3()
    
25. Start = Timer    '計時開始
    
26. Dim d As Object
    
27. Set d = CreateObject("Scripting.Dictionary")
    
28. 
    
29. With ActiveSheet
    
30.     For i = 1 To 50000
    
31.         d(i) = Cells(i, 1) + Cells(i, 2)
    
32.     Next
    
33.     Range("C1:C50000") = Application.Transpose(d.items)
    
34. End With
    
35. 
    
36. Set d = Nothing
    
37. 
    
38. MsgBox "Completion in  " & Format((Timer - Start) / 86400, "hh:mm:ss")   '計時結束 Sub
    
39. End Sub

複製代碼

======================
切入正題:

D欄是種類,我想要讓C欄的值依照各種類排在對應的欄
譬如第1,3列是種類A,第2,5列是種類B,第4列是種類C
我先用字典移除重複後,在第50001列的E,F,G欄列出三個種類
然後每一列就會依照50001列列出的數字,把C欄的值依種類排在該欄
類似樞紐分析那樣

我的疑問是,無論我如何嘗試,就是做不出A欄+B欄那種速度(0秒)
一樣都是50000列,目前速度僅能達3秒
1.用loop+if讀出每列對應的欄號
2.用字典把每一列應在哪一欄讀進去,再讀出來
3.同2,不過讀出來的方式換成offset

結果是方法2=3,花費3秒,方法1花費6秒
我不懂的地方是為什麼用字典相加50000列可以0秒達成
但是分欄排序50000列就會耗時較久
有人可以指點迷津嗎
謝謝

======================

1. Public Sub 分欄測試1()
   
2. Start = Timer        '計時開始
   
3. Dim d As Object
   
4. Set d = CreateObject("scripting.dictionary")
   
5. With ActiveSheet
   
6.     arr1 = .Range("D1:D50000")   '利用字典特性移除重複
   
7.     For i = 1 To 50000
   
8.         d(arr1(i, 1)) = 1
   
9.     Next
   
10.    
    
11.     For i = 1 To 6
    
12.         .Range("E50001").Resize(1, d.Count) = d.keys    '於第50001列列出所有種類
    
13.     Next
    
14.    
    
15.     For i = 1 To 50000
    
16.             For j = 1 To 6
    
17.                 If .Cells(i, 4) = .Cells(50001, 4 + j) Then
    
18.                 k = j + 4                                '讀出每列應該擺在哪一欄
    
19.                 End If
    
20.             Next j
    
21.         .Cells(i, k) = .Cells(i, 3)   '依序按欄號列出對應值
    
22.     Next i
    
23.    
    
24. Set d = Nothing
    
25. Set arr1 = Nothing
    
26. End With
    
27. 
    
28. MsgBox "Completion in  " & Format((Timer - Start) / 86400, "hh:mm:ss")   '計時結束
    
29.    
    
30. End Sub
    
31. ======================
    
32. Public Sub 分欄測試2()
    
33. Start = Timer          '計時開始
    
34. 
    
35. Dim d1 As Object
    
36. Dim d2 As Object
    
37. Set d1 = CreateObject("scripting.dictionary")
    
38. Set d2 = CreateObject("scripting.dictionary")
    
39. 
    
40. With ActiveSheet
    
41. 
    
42.     arr1 = .Range("D1:D50000")     '利用字典特性移除重複
    
43.     For i = 1 To 50000
    
44.         d1(arr1(i, 1)) = 1
    
45.     Next
    
46.    
    
47.     For i = 1 To 6
    
48.         .Range("E50001").Resize(1, d1.Count) = d1.keys   '於第50001列列出所有種類
    
49.     Next
    
50.    
    
51.     For i = 1 To 6
    
52.         d2(.Range(Chr(68 + i) & "50001").Value) = i + 4  '讀出每列應該擺在哪一欄
    
53.     Next
    
54.    
    
55.     For i = 1 To 50000
    
56.         .Cells(i, d2(.Range("D" & i).Value)) = .Cells(i, 3)   '依序按欄號列出對應值
    
57.     Next i
    
58.    
    
59. 
    
60. Set d1 = Nothing
    
61. Set d2 = Nothing
    
62. Set arr1 = Nothing
    
63. 
    
64. End With
    
65. 
    
66. MsgBox "Completion in  " & Format((Timer - Start) / 86400, "hh:mm:ss")   '計時結束
    
67.    
    
68. End Sub
    
69. =================
    
70. Public Sub 分欄測試3()
    
71. Start = Timer    '計時開始
    
72. 
    
73. Dim d1 As Object
    
74. Dim d2 As Object
    
75. Set d1 = CreateObject("scripting.dictionary")
    
76. Set d2 = CreateObject("scripting.dictionary")
    
77. 
    
78. With ActiveSheet
    
79.     arr1 = .Range("D1:D50000")   '利用字典特性移除重複
    
80.     For i = 1 To 50000
    
81.         d1(arr1(i, 1)) = 1
    
82.     Next
    
83.    
    
84.     For i = 1 To 6
    
85.         .Range("E50001").Resize(1, d1.Count) = d1.keys   '於第50001列列出所有種類
    
86.     Next
    
87.    
    
88.     For i = 1 To 6
    
89.         d2(.Range(Chr(68 + i) & "50001").Value) = i + 1   '讀出每列應該擺在哪一欄
    
90.     Next
    
91.    
    
92.     For i = 1 To 50000
    
93.         .Cells(i, 3).Offset(0, d2(.Range("D" & i).Value)) = .Cells(i, 3)   '依序按欄號列出對應值
    
94.     Next i
    
95.    
    
96. 
    
97. Set d1 = Nothing
    
98. Set d2 = Nothing
    
99. Set arr1 = Nothing
    
100. 
     
101. End With
     
102. 
     
103. MsgBox "Completion in  " & Format((Timer - Start) / 86400, "hh:mm:ss")   '計時結束
     
104.    
     
105. End Sub

複製代碼

==========================
附件一直傳不上去..
我放在我的ftp...
http://iamjo.myweb.hinet.net/分欄排列.xls