VBA尋找重複
程式碼是在網上取來套用的,但搜尋速度實在太慢了.
是否有更好的語法可加快搜尋速度
謝謝!
[attach]29291[/attach] [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=104872&ptid=21077]1#[/url] [i]Qin[/i] [/b]
[attach]29294[/attach]
快一些些(程序test2)，字典物件也就這樣了，期待有更好的寫法
程序test1=原程序+計時器
話說...."[color=Red]笭葩[/color]" 是什麼意思?[code]Private Sub test2()
t1 = Timer
Application.ScreenUpdating = False
Dim arr As Range, brr()
Dim i As Long, Rn As Long
Dim Dict As Object
On Error Resume Next
Set Dict = CreateObject("scripting.dictionary")
With ActiveSheet
Set arr = Intersect(.UsedRange, .Columns(3))
Rn = arr.Cells.Count
ReDim brr(1 To Rn)
For i = 1 To Rn
Dict(arr(i).Value) = Dict(arr(i).Value) + 1
Next i
For i = 1 To Rn
If Dict(arr(i).Value) <> 1 Then brr(i) = "重覆"
Next i
.Columns(2) = ""
.Range("b1").Resize(Rn, 1) = Application.Transpose(brr)
End With
Application.ScreenUpdating = True
MsgBox "test2共耗時" & Round(Timer - t1, 3) & "秒"
End Sub[/code] Sub test_01()
Dim Arr, xD, i&, T$, U&, TM
TM = Timer
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([C2], Cells(Rows.Count, 3).End(3))
For i = 1 To UBound(Arr)
T = Arr(i, 1): U = xD(T): Arr(i, 1) = ""
If U > 0 Then Arr(U, 1) = "重覆": xD(T) = -1: U = -1
If U < 0 Then Arr(i, 1) = "重覆"
If U = 0 Then xD(T) = i
Next i
[B2].Resize(UBound(Arr)) = Arr
MsgBox Timer - TM
End Sub
五萬多筆, 約一秒內可完成~~ [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=104875&ptid=21077]3#[/url] [i]准提部林[/i] [/b]
我原本還傻傻地想說用 for迴圈加上countif
然後就當機了 XD [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=104877&ptid=21077]4#[/url] [i]a5007185[/i] [/b]
如果用VBA, 非不得已才去用函數, 儘量避免,
一般的公式解, COUNTIF也是特別慢, 資料一多, 準卡檔! Sub test_02()
Dim Arr, Brr, xD, i&, TM
TM = Timer
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([C2], Cells(Rows.Count, 3).End(3))
ReDim Brr(1 To UBound(Arr), 0)
For i = 1 To UBound(Arr)
xD(Arr(i, 1) & "") = xD(Arr(i, 1) & "") + 1
Next i
For i = 1 To UBound(Arr)
If xD(Arr(i, 1) & "") > 1 Then Brr(i, 0) = "重覆"
Next
[B2].Resize(UBound(Arr)) = Brr
MsgBox Timer - TM
End Sub
這是基本套路, 用了兩個迴圈, 慢一些些~~
xD(Arr(i, 1) [color=red]& ""[/color]) 加 "" 是為防止[純數字]在數值格式與文字格式不同而產生差異! [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=104875&ptid=21077]3#[/url] [i]准提部林[/i] [/b]
謝謝准大
跟之前的速度相比 ,現在好像坐上高鐵... [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=104879&ptid=21077]6#[/url] [i]准提部林[/i] [/b]
準大太厲害啦，原來字典物件輸入的key是[color=Red]字串型態[/color]的話，速度可以提昇那麼多!!!
如果是非字串，速度整個慢下來!
另外用字典記錄上一個重覆的列號並且一起輸入"重覆"的寫法也很棒，可以只用一個迴圈 [i=s] 本帖最後由 GBKEE 於 2018-8-31 09:12 編輯 [/i]
[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=104896&ptid=21077]7#[/url] [i]Qin[/i] [/b]
輔助欄+排序+IF公式[code]Sub Ex()
Dim xTime As Date
xTime = Time
Debug.Print Time
With Range("C2:C" & [C2].End(xlDown).Row) '資料欄
.Offset(, 1) = "=ROW()" '輔助欄
.CurrentRegion.Sort KEY1:=.Cells(1), Header:=xlYes '排序以資料欄為主鍵
.Offset(, -1) = "=IF(OR(RC[1]=R[-1]C[1], RC[1]=R[1]C[1]),""重複"","""")" '要顯示重複的欄寫上公式
.CurrentRegion.Value = .CurrentRegion.Value '將公式轉為數值
.CurrentRegion.Sort KEY1:=.Cells(1, 2), Header:=xlYes '排序以輔助欄為主鍵 :還原資料欄原有的排列
.Offset(, 1) = "" '清除輔助欄
End With
Debug.Print Time
MsgBox Application.Text(Time - xTime, ["計時 ss 秒"])
End Sub[/code] [quote]回復 准提部林
準大太厲害啦，原來字典物件輸入的key是字串型態的話，速度可以提昇那麼多!!!
如果 ...
[size=2][color=#999999]n7822123 發表於 2018-8-31 01:11[/color] [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=104899&ptid=21077][img]http://forum.twbts.com/images/common/back.gif[/img][/url][/size][/quote]
3個語法,可看懂2個,唯獨准大的第1個程式碼,我想了好久,針對以下語法
For i = 1 To UBound(Arr)
T = Arr(i, 1): U = xD(T): Arr(i, 1) = ""
If U > 0 Then Arr(U, 1) = "重覆": xD(T) = -1: U = -1
If U < 0 Then Arr(i, 1) = "重覆"
If U = 0 Then xD(T) = i
Next i
還是想不透為何如此就能判斷出重覆與否,那位大大可以幫忙解說一下嗎? [i=s] 本帖最後由 jackyq 於 2018-9-28 08:40 編輯 [/i]
[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=105302&ptid=21077]10#[/url] [i]千暉尋[/i] [/b]
你看不懂是因為多了2段藍字跳板 , 跳板內又存在著 U 在 -1, 列位置 二值之間來回交替切換
你可以把跳板移除 , 等效如下
Sub test_01a()
Dim Arr, xD, i&, T$, U&, TM
TM = Timer
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([C2], Cells(Rows.Count, 3).End(3))
For i = 1 To UBound(Arr)
T = Arr(i, 1): U = xD(T): Arr(i, 1) = ""
If U > 0 Then Arr([color=RoyalBlue][b]i[/b][/color], 1) = "重覆"[color=RoyalBlue][b] ': xD(T) = -1: U = -1[/color][/b]
[b][color=RoyalBlue] 'If U < 0 Then Arr(i, 1) = "重覆"[/color][/b]
If U = 0 Then xD(T) = i
Next i
[B2].Resize(UBound(Arr)) = Arr
'MsgBox Timer - TM
End Sub [i=s] 本帖最後由 准提部林 於 2018-9-28 10:04 編輯 [/i]
[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=105302&ptid=21077]10#[/url] [i]千暉尋[/i] [/b]
U=xD(T) 先取出字典的ITEM值, 若T值還未丟進字典, U 值為0(或"")
U=0 表示尚未掃過的KEY, 先給值 i 保留後用 (相當于列號)
U>0 表示是第2次掃到的, 其ITEM值是上一次保留的"列號", 順勢將上一次的位置標示"重覆", 再將 ITEM 改成 -1
U<0 表示已掃過2次以上, 直接標示"重覆" [quote]回復 千暉尋
U=xD(T) 先取出字典的ITEM值, 若T值還未丟進字典, U 值為0(或"")
U=0 表示尚未掃過的 ...
[size=2][color=#999999]准提部林 發表於 2018-9-28 10:01[/color] [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=105308&ptid=21077][img]http://forum.twbts.com/images/common/back.gif[/img][/url][/size][/quote]
謝謝準大的說明,簡明扼要,我曾試過,第1次出現U值都是0 ,想不通為何,還在鑽牛角尖想說0到底是KEY值還是ITEM值,原來兩者都不是,是根本還沒寫入,一語警醒夢中人! [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=105308&ptid=21077]12#[/url] [i]准提部林[/i] [/b]
尋找同一欄重覆資料
(只顯示多個重覆中的其中的1個)
[attach]29491[/attach] [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=105383&ptid=21077]14#[/url] [i]Qin[/i] [/b]
只標示有重覆的[最後一個]
Sub test_03()
Dim Arr, xD, i&, T$, U&, TM
TM = Timer
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([C2], Cells(Rows.Count, 3).End(3))
For i = UBound(Arr) To 1 Step -1
T = Arr(i, 1): U = xD(T): Arr(i, 1) = ""
If U > 0 Then Arr(U, 1) = "Rept": xD(T) = -1
If U = 0 Then xD(T) = i
Next i
[B2].Resize(UBound(Arr)) = Arr
MsgBox Timer - TM
End Sub [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=105395&ptid=21077]15#[/url] [i]准提部林[/i] [/b]
這是原本想要的搜尋結果, 但自己發錯的問題...
無論如何, 謝謝准大..
Rept code
40000001
Rept 40000001
40000002
Rept 40000002
40000003
40000004
Rept 40000004
40000005
Rept 40000005
40000006
Rept 40000006
Rept 40000006
Rept 40000006
Sub test_04()
Dim Arr, xD, i&, T$, U&, TM
TM = Timer
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([C2], Cells(Rows.Count, 3).End(3))
For i = UBound(Arr) To 1 Step -1
T = Arr(i, 1): U = xD(T): Arr(i, 1) = ""
If U > 0 Then Arr(U, 1) = "Rept": xD(T) = -1: U = -0
If U = 0 Then xD(T) = i
Next i
[B2].Resize(UBound(Arr)) = Arr
MsgBox Timer - TM
End Sub [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=104875&ptid=21077]3#[/url] [i]准提部林[/i] [/b]
謝謝前輩
後學藉此帖學習前輩的方案,方案學習心得註解如下,請前輩在指導
執行前:
[attach]36371[/attach]
執行結果:
[attach]36372[/attach]
Option Explicit
Sub test_01()
Dim Arr, xD, i&, T$, U&, TM
[color=SeaGreen]'↑宣告變數[/color]
TM = Timer
Set xD = CreateObject("Scripting.Dictionary")
[color=SeaGreen]'↑令xD變數是 字典[/color]
Arr = Range([C2], Cells(Rows.Count, 3).End(3))
[color=SeaGreen]'↑令Arr變數是 二維陣列,以儲存格值帶入陣列中[/color]
For i = 1 To UBound(Arr)
[color=SeaGreen]'↑設順迴圈[/color]
T = Arr(i, 1): U = xD(T): Arr(i, 1) = ""
[color=SeaGreen] '↑令T變數是 Arr陣列值(關鍵字),
'令U變數是 關鍵字查xD字典的item值
'令清除掉Arr陣列裡的值[/color]
If U > 0 Then Arr(U, 1) = "重覆": xD(T) = -1: U = -1
[color=SeaGreen] '↑如果U變數大於0,代表此關鍵字在Arr陣列i列值還不是 "重覆",
'也就是初次檢查到重覆!就令Arr陣列U變數列值是 "重覆"字串,
'令此關鍵字的item改為-1,令U變數是 -1[/color]
If U < 0 Then Arr(i, 1) = "重覆"
[color=SeaGreen] '↑如果U變數小於0,代表Arr陣列這迴圈列值是重複的,
'就令Arr陣列i迴圈列值是 "重覆"字串[/color]
If U = 0 Then xD(T) = i
[color=SeaGreen] '↑如果U變數是 0,代表此關鍵字是第1次出現,
'只以此關鍵字當key,item是i迴圈數要納入xD字典裡就好[/color]
Next i
[B2].Resize(UBound(Arr)) = Arr
[color=SeaGreen]'↑令Arr陣列值從[B2]擴展的儲存格中寫入[/color]
MsgBox Timer - TM
End Sub
頁:
[1]