返回列表 上一主題 發帖

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

mpegwmvavi

帖子
11 
主題
4 
精華
0 
積分
21 
點名
0  
作業系統
win7 
軟體版本
office2011 
閱讀權限
10 
性別
男 
註冊時間
2011-5-5 
最後登錄
2015-6-27 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2015-4-5 01:13 | 只看該作者

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

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

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

代碼如下
  1. Public Sub 兩欄相加1()
  2. Start = Timer    '計時開始

  4. With ActiveSheet
  5.     For i = 1 To 50000
  6.         .Cells(i, 3) = .Cells(i, 1) + .Cells(i, 2)
  7.     Next
  8. End With

  10. MsgBox "Completion in  " & Format((Timer - Start) / 86400, "hh:mm:ss")   '計時結束
  11. ===================
  12. Public Sub 兩欄相加2()
  13. Start = Timer    '計時開始

  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

  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")

  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

  36. Set d = Nothing

  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

  28. MsgBox "Completion in  " & Format((Timer - Start) / 86400, "hh:mm:ss")   '計時結束
  29.    
  30. End Sub
  31. ======================
  32. Public Sub 分欄測試2()
  33. Start = Timer          '計時開始

  35. Dim d1 As Object
  36. Dim d2 As Object
  37. Set d1 = CreateObject("scripting.dictionary")
  38. Set d2 = CreateObject("scripting.dictionary")

  40. With ActiveSheet

  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.    

  60. Set d1 = Nothing
  61. Set d2 = Nothing
  62. Set arr1 = Nothing

  64. End With

  66. MsgBox "Completion in  " & Format((Timer - Start) / 86400, "hh:mm:ss")   '計時結束
  67.    
  68. End Sub
  69. =================
  70. Public Sub 分欄測試3()
  71. Start = Timer    '計時開始

  73. Dim d1 As Object
  74. Dim d2 As Object
  75. Set d1 = CreateObject("scripting.dictionary")
  76. Set d2 = CreateObject("scripting.dictionary")

  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.    

  97. Set d1 = Nothing
  98. Set d2 = Nothing
  99. Set arr1 = Nothing

  101. End With

  103. MsgBox "Completion in  " & Format((Timer - Start) / 86400, "hh:mm:ss")   '計時結束
  104.    
  105. End Sub
複製代碼
==========================
附件一直傳不上去..
我放在我的ftp...
http://iamjo.myweb.hinet.net/分欄排列.xls
收藏 分享
MPEG

        靜思自在 : 有智慧才能分辨善惡邪正；有謙虛才能建立美滿人生。
返回列表 上一主題