VBA尋找重複

Qin

程式碼是在網上取來套用的,

    但搜尋速度實在太慢了.

    是否有更好的語法可加快搜尋速度

    謝謝!

    Rept.rar (525.45 KB)

下載次數: 65

2018-8-30 00:07

Andy2483

回復 3# 准提部林


    謝謝前輩
後學藉此帖學習前輩的方案,方案學習心得註解如下,請前輩在指導

執行前:

下載 (95.08 KB)

2023-5-16 14:45

執行結果:

下載 (101.75 KB)

2023-5-16 14:45

Option Explicit
Sub test_01()
Dim Arr, xD, i&, T$, U&, TM
'↑宣告變數
TM = Timer
Set xD = CreateObject("Scripting.Dictionary")
'↑令xD變數是 字典
Arr = Range([C2], Cells(Rows.Count, 3).End(3))
'↑令Arr變數是 二維陣列,以儲存格值帶入陣列中
For i = 1 To UBound(Arr)
'↑設順迴圈
    T = Arr(i, 1):  U = xD(T):  Arr(i, 1) = ""
    '↑令T變數是 Arr陣列值(關鍵字),
    '令U變數是 關鍵字查xD字典的item值
    '令清除掉Arr陣列裡的值
    If U > 0 Then Arr(U, 1) = "重覆": xD(T) = -1: U = -1
    '↑如果U變數大於0,代表此關鍵字在Arr陣列i列值還不是 "重覆",
    '也就是初次檢查到重覆!就令Arr陣列U變數列值是 "重覆"字串,
    '令此關鍵字的item改為-1,令U變數是 -1
    If U < 0 Then Arr(i, 1) = "重覆"
    '↑如果U變數小於0,代表Arr陣列這迴圈列值是重複的,
    '就令Arr陣列i迴圈列值是 "重覆"字串
    If U = 0 Then xD(T) = i
    '↑如果U變數是 0,代表此關鍵字是第1次出現,
    '只以此關鍵字當key,item是i迴圈數要納入xD字典裡就好
Next i
[B2].Resize(UBound(Arr)) = Arr
'↑令Arr陣列值從[B2]擴展的儲存格中寫入
MsgBox Timer - TM
End Sub

Qin

回復 15# 准提部林

這是原本想要的搜尋結果, 但自己發錯的問題...
無論如何, 謝謝准大..

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

准提部林

回復 14# Qin

只標示有重覆的[最後一個]

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

Qin

回復 12# 准提部林


    尋找同一欄重覆資料       
       
(只顯示多個重覆中的其中的1個)

Rept.rar (54.61 KB)

下載次數: 10

2018-10-3 23:08

千暉尋

回復  千暉尋

U=xD(T) 先取出字典的ITEM值, 若T值還未丟進字典, U 值為0(或"")

U=0  表示尚未掃過的 ...
准提部林 發表於 2018-9-28 10:01

謝謝準大的說明,簡明扼要,我曾試過,第1次出現U值都是0 ,想不通為何,還在鑽牛角尖想說0到底是KEY值還是ITEM值,原來兩者都不是,是根本還沒寫入,一語警醒夢中人!

准提部林

回復 10# 千暉尋

U=xD(T) 先取出字典的ITEM值, 若T值還未丟進字典, U 值為0(或"")

U=0  表示尚未掃過的KEY, 先給值 i 保留後用 (相當于列號)
U>0  表示是第2次掃到的, 其ITEM值是上一次保留的"列號", 順勢將上一次的位置標示"重覆", 再將 ITEM 改成 -1
U<0  表示已掃過2次以上, 直接標示"重覆"

jackyq

回復 10# 千暉尋

你看不懂是因為多了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(i, 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

千暉尋

回復  准提部林


準大太厲害啦，原來字典物件輸入的key是字串型態的話，速度可以提昇那麼多!!!

如果 ...
n7822123 發表於 2018-8-31 01:11

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
還是想不透為何如此就能判斷出重覆與否,那位大大可以幫忙解說一下嗎?

GBKEE

回復 7# Qin
輔助欄+排序+IF公式

1. Sub Ex()
   
2.     Dim xTime As Date
   
3.     xTime = Time
   
4.     Debug.Print Time
   
5.     With Range("C2:C" & [C2].End(xlDown).Row) '資料欄
   
6.         .Offset(, 1) = "=ROW()"    '輔助欄
   
7.         .CurrentRegion.Sort KEY1:=.Cells(1), Header:=xlYes    '排序以資料欄為主鍵
   
8.         .Offset(, -1) = "=IF(OR(RC[1]=R[-1]C[1], RC[1]=R[1]C[1]),""重複"","""")"    '要顯示重複的欄寫上公式
   
9.         .CurrentRegion.Value = .CurrentRegion.Value         '將公式轉為數值
   
10.         .CurrentRegion.Sort KEY1:=.Cells(1, 2), Header:=xlYes  '排序以輔助欄為主鍵 :還原資料欄原有的排列
    
11.         .Offset(, 1) = ""   '清除輔助欄
    
12.     End With
    
13.     Debug.Print Time
    
14.     MsgBox Application.Text(Time - xTime, ["計時 ss 秒"])
    
15. End Sub

複製代碼