Qin

帖子: 207
主題: 61
精華: 0
積分: 270
點名: 0
作業系統: Vista
軟體版本: office2003
閱讀權限: 20
性別: 女
註冊時間: 2011-3-20
最後登錄: 2023-6-25

1^# 跳轉到 » 正序看帖

打印

字體大小: tT

發表於 2018-8-30 00:08 | 只看該作者

VBA尋找重複

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

但搜尋速度實在太慢了.

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

謝謝!

Rept.rar (525.45 KB)

樓主熱帖

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-10-21

17^#

發表於 2023-5-16 14:46 | 只看該作者

回復 3# 准提部林

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

執行前:

執行結果:

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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Qin

中學生 Rank: 2

帖子: 207
主題: 61
精華: 0
積分: 270
點名: 0
作業系統: Vista
軟體版本: office2003
閱讀權限: 20
性別: 女
註冊時間: 2011-3-20
最後登錄: 2023-6-25

16^#

發表於 2018-10-7 14:24 | 只看該作者

回復 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

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-23

15^#

發表於 2018-10-4 11:20 | 只看該作者

回復 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

TOP

Qin

中學生 Rank: 2

帖子: 207
主題: 61
精華: 0
積分: 270
點名: 0
作業系統: Vista
軟體版本: office2003
閱讀權限: 20
性別: 女
註冊時間: 2011-3-20
最後登錄: 2023-6-25

14^#

發表於 2018-10-3 23:08 | 只看該作者

回復 12# 准提部林

尋找同一欄重覆資料

(只顯示多個重覆中的其中的1個)

Rept.rar (54.61 KB)

TOP

千暉尋

中學生 Rank: 2

帖子: 36
主題: 7
精華: 0
積分: 77
點名: 0
作業系統: WIN7
軟體版本: MICROSOFT
閱讀權限: 20
註冊時間: 2015-6-7
最後登錄: 2024-9-22

論壇榮譽勳章論壇贊助勳章

13^#

發表於 2018-9-28 16:45 | 只看該作者

回復千暉尋

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

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

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

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-23

12^#

發表於 2018-9-28 10:01 | 只看該作者

本帖最後由准提部林於 2018-9-28 10:04 編輯

回復 10# 千暉尋

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

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

TOP

jackyq

中學生 Rank: 2

帖子: 319
主題: 6
精華: 0
積分: 309
點名: 0
作業系統: xp
軟體版本: 2k
閱讀權限: 20
性別: 男
註冊時間: 2015-6-24
最後登錄: 2024-4-27

11^#

發表於 2018-9-28 08:37 | 只看該作者

本帖最後由 jackyq 於 2018-9-28 08:40 編輯

回復 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

TOP

千暉尋

中學生 Rank: 2

帖子: 36
主題: 7
精華: 0
積分: 77
點名: 0
作業系統: WIN7
軟體版本: MICROSOFT
閱讀權限: 20
註冊時間: 2015-6-7
最後登錄: 2024-9-22

論壇榮譽勳章論壇贊助勳章

10^#

發表於 2018-9-27 15:07 | 只看該作者

回復准提部林

準大太厲害啦，原來字典物件輸入的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

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

9^#

發表於 2018-8-31 08:39 | 只看該作者

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

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

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

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP