VBA尋找重複

Qin

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

    但搜尋速度實在太慢了.

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

    謝謝!

    Rept.rar (525.45 KB)

下載次數: 65

2018-8-30 00:07

n7822123

回復 1# Qin

Rept+1.rar (446.33 KB)

下載次數: 12

2018-8-30 02:55

快一些些(程序test2)，字典物件也就這樣了，期待有更好的寫法

程序test1=原程序+計時器

話說...."笭葩" 是什麼意思?

1. Private Sub test2()
   
2.     t1 = Timer
   
3.     Application.ScreenUpdating = False
   
4.     Dim arr As Range, brr()
   
5.     Dim i As Long, Rn As Long
   
6.     Dim Dict As Object
   
7.     On Error Resume Next
   
8.     Set Dict = CreateObject("scripting.dictionary")
   
9.     With ActiveSheet
   
10.        Set arr = Intersect(.UsedRange, .Columns(3))
    
11.        Rn = arr.Cells.Count
    
12.         ReDim brr(1 To Rn)
    
13.         For i = 1 To Rn
    
14.           Dict(arr(i).Value) = Dict(arr(i).Value) + 1
    
15.         Next i
    
16.         For i = 1 To Rn
    
17.             If Dict(arr(i).Value) <> 1 Then brr(i) = "重覆"
    
18.         Next i
    
19.         .Columns(2) = ""
    
20.         .Range("b1").Resize(Rn, 1) = Application.Transpose(brr)
    
21.     End With
    
22.     Application.ScreenUpdating = True
    
23.     MsgBox "test2共耗時" & Round(Timer - t1, 3) & "秒"
    
24. End Sub

複製代碼

准提部林

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

五萬多筆, 約一秒內可完成~~

a5007185

回復 3# 准提部林

我原本還傻傻地想說用 for迴圈加上countif  
然後就當機了  XD

准提部林

回復 4# a5007185


如果用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) & "")  加 "" 是為防止[純數字]在數值格式與文字格式不同而產生差異!

Qin

回復 3# 准提部林

  謝謝准大

   跟之前的速度相比 ,現在好像坐上高鐵...

n7822123

回復 6# 准提部林


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

如果是非字串，速度整個慢下來!   

另外用字典記錄上一個重覆的列號並且一起輸入"重覆"的寫法也很棒，可以只用一個迴圈

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

複製代碼

千暉尋

回復  准提部林


準大太厲害啦，原來字典物件輸入的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
還是想不透為何如此就能判斷出重覆與否,那位大大可以幫忙解說一下嗎?