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

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

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

代碼如下

Public Sub 兩欄相加1()
Start = Timer '計時開始
With ActiveSheet
For i = 1 To 50000
.Cells(i, 3) = .Cells(i, 1) + .Cells(i, 2)
Next
End With
MsgBox "Completion in " & Format((Timer - Start) / 86400, "hh:mm:ss") '計時結束
===================
Public Sub 兩欄相加2()
Start = Timer '計時開始
With ActiveSheet
For i = 1 To 50000
.Cells(i, 3) = Application.WorksheetFunction.Sum(.Cells(i, 1), .Cells(i, 2))
Next
End With
MsgBox "Completion in " & Format((Timer - Start) / 86400, "hh:mm:ss") '計時結束 Sub
End Sub
===============
Public Sub 兩欄相加3()
Start = Timer '計時開始
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
With ActiveSheet
For i = 1 To 50000
d(i) = Cells(i, 1) + Cells(i, 2)
Next
Range("C1:C50000") = Application.Transpose(d.items)
End With
Set d = Nothing
MsgBox "Completion in " & Format((Timer - Start) / 86400, "hh:mm:ss") '計時結束 Sub
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列就會耗時較久
有人可以指點迷津嗎
謝謝

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

Public Sub 分欄測試1()
Start = Timer '計時開始
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
arr1 = .Range("D1:D50000") '利用字典特性移除重複
For i = 1 To 50000
d(arr1(i, 1)) = 1
Next
For i = 1 To 6
.Range("E50001").Resize(1, d.Count) = d.keys '於第50001列列出所有種類
Next
For i = 1 To 50000
For j = 1 To 6
If .Cells(i, 4) = .Cells(50001, 4 + j) Then
k = j + 4 '讀出每列應該擺在哪一欄
End If
Next j
.Cells(i, k) = .Cells(i, 3) '依序按欄號列出對應值
Next i
Set d = Nothing
Set arr1 = Nothing
End With
MsgBox "Completion in " & Format((Timer - Start) / 86400, "hh:mm:ss") '計時結束
End Sub
======================
Public Sub 分欄測試2()
Start = Timer '計時開始
Dim d1 As Object
Dim d2 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
With ActiveSheet
arr1 = .Range("D1:D50000") '利用字典特性移除重複
For i = 1 To 50000
d1(arr1(i, 1)) = 1
Next
For i = 1 To 6
.Range("E50001").Resize(1, d1.Count) = d1.keys '於第50001列列出所有種類
Next
For i = 1 To 6
d2(.Range(Chr(68 + i) & "50001").Value) = i + 4 '讀出每列應該擺在哪一欄
Next
For i = 1 To 50000
.Cells(i, d2(.Range("D" & i).Value)) = .Cells(i, 3) '依序按欄號列出對應值
Next i
Set d1 = Nothing
Set d2 = Nothing
Set arr1 = Nothing
End With
MsgBox "Completion in " & Format((Timer - Start) / 86400, "hh:mm:ss") '計時結束
End Sub
=================
Public Sub 分欄測試3()
Start = Timer '計時開始
Dim d1 As Object
Dim d2 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
With ActiveSheet
arr1 = .Range("D1:D50000") '利用字典特性移除重複
For i = 1 To 50000
d1(arr1(i, 1)) = 1
Next
For i = 1 To 6
.Range("E50001").Resize(1, d1.Count) = d1.keys '於第50001列列出所有種類
Next
For i = 1 To 6
d2(.Range(Chr(68 + i) & "50001").Value) = i + 1 '讀出每列應該擺在哪一欄
Next
For i = 1 To 50000
.Cells(i, 3).Offset(0, d2(.Range("D" & i).Value)) = .Cells(i, 3) '依序按欄號列出對應值
Next i
Set d1 = Nothing
Set d2 = Nothing
Set arr1 = Nothing
End With
MsgBox "Completion in " & Format((Timer - Start) / 86400, "hh:mm:ss") '計時結束
End Sub

複製代碼

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

樓主熱帖

MPEG

bobomi

中學生 Rank: 2

帖子: 181
主題: 5
精華: 0
積分: 197
點名: 0
作業系統: XP
軟體版本: 2000
閱讀權限: 20
性別: 女
註冊時間: 2014-3-9
最後登錄: 2024-4-29

2^#

發表於 2015-4-5 07:17 | 只看該作者

本帖最後由 bobomi 於 2015-4-5 07:18 編輯

之所以暴快不是在於字典
而是在於你用了 "1次性填充的方式"  Range("C1:C50000") = Application.Transpose(d.items)

解法類似如下

Col3 = [C1 : C50000].Value
col4 = [D1 : D50000].Value
Dim ar(1 To 50000, 1 To 6)
For i = 1 To 50000
   ' .Cells(i, 3).Offset(0, d2(.Range("D" & i).Value)) = .Cells(i, 3) '依序按欄號列出對應值
      ar(i, d2(col4(i, 1))) = Col3(i, 1) '依序按欄號列出對應值
Next i

.Cells(1, 9).Resize(50000, 6) = ar ' ---> 1次性填充

TOP

mpegwmvavi