返回列表 上一主題 發帖

VBA尋找重複

VBA尋找重複

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

    但搜尋速度實在太慢了.

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

    謝謝!

    Rept.rar (525.45 KB)

回復 1# Qin

Rept+1.rar (446.33 KB)

快一些些(程序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
複製代碼

TOP

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

五萬多筆, 約一秒內可完成~~
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

回復 3# 准提部林

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

TOP

回復 4# a5007185


如果用VBA, 非不得已才去用函數, 儘量避免,
一般的公式解, COUNTIF也是特別慢, 資料一多, 準卡檔!
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

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) & "")  加 "" 是為防止[純數字]在數值格式與文字格式不同而產生差異!
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

回復 3# 准提部林

  謝謝准大

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

TOP

回復 6# 准提部林


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

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

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

TOP

本帖最後由 GBKEE 於 2018-8-31 09:12 編輯

回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復  准提部林


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

TOP

        靜思自在 : 吃苦了苦、苦盡廿來,享福了福、福盡悲來。
返回列表 上一主題