麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 如何使用陣列+字典物件比對資料的時候用LIKE語法? [打印本頁]

作者: PKKO 時間: 2015-9-16 08:19 標題: 如何使用陣列+字典物件比對資料的時候用LIKE語法?

本帖最後由 PKKO 於 2015-9-16 08:20 編輯

不好意思,麻煩各位大大了,我覺得TEST_1的程式碼執行速度較快,但我只會用TEST_2的方式,有大大可以教學一下嗎?

Sub TEST_1()
'這是原本的程式碼
[B:B].Clear: [J1] = ""
xRow = 10
Arr = [A1].Resize(xRow)
Brr = [C1].Resize(xRow)
Set xD = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Brr)
xD(Brr(i, 1)) = xD(Brr(i, 1)) + 1
Next
For i = 1 To UBound(Arr)
Arr(i, 1) = xD(Arr(i, 1))
Next
[B1].Resize(xRow) = Arr
End Sub
Sub TEST_2()
'我想將TEST_1模組的程式碼改成用LIKE的方式,不曉得該怎麼做???
'我只會下列這種方式
xRow = 10
Arr = [A1].Resize(xRow)
Brr = [C1].Resize(xRow)
Dim AA
ReDim AA(1 To 10, 1 To 1)
For i = 1 To UBound(Arr)
M = 0
For J = 1 To UBound(Brr)
If Brr(J, 1) Like "*" & Arr(i, 1) & "*" Then
M = M + 1
AA(i, 1) = M
End If
Next
Next
[B1].Resize(xRow) = AA
End Sub

複製代碼

作者: GBKEE 時間: 2015-9-16 09:28

回復 1# PKKO
試試看

Option Explicit
Sub TEST_2()
Dim xRow As Integer, Arr(), Brr(), Ar()
xRow = 10
Arr = [A1].Resize(xRow).Value
Brr = [C1].Resize(xRow).Value
ReDim Ar(1 To UBound(Arr), 1 To UBound(Arr, 2)) '設置一個與Arr同樣大小陣列(空的)
ReDim AA(1 To 10, 1 To 1)
For i = 1 To UBound(Arr)
For J = 1 To UBound(Brr)
If Brr(J, 1) Like "*" & Arr(i, 1) & "*" Then
'Like 運算子用來比較兩個字串有相同的字
'If Brr(J, 1) = Arr(i, 1) Then '兩者相同
Ar(i, 1) = Ar(i, 1) + 1
End If
Next
Next
[B1].Resize(xRow) = Ar
End Sub

複製代碼

作者: ikboy 時間: 2015-9-16 09:42

回復 1# PKKO

Sub TEST_1()

[B:B].Clear: [J1] = ""
xRow = 10
arr = [A1].Resize(xRow)
Brr = [C1].Resize(xRow)
Set xd = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Brr)
xd(Brr(i, 1)) = 0
Next
k = xd.keys
t = xd.items
For i = 1 To UBound(arr)
For j = 0 To UBound(k)
If InStr(k(j), arr(i, 1)) Then t(i - 1) = t(i - 1) + 1
Next
Next
[B1].Resize(xRow) = Application.Transpose(t)
End Sub

作者: PKKO 時間: 2015-9-16 19:57

回復 2# GBKEE

感謝超版大大的回覆,但您的方式似乎與我的TEST_2模組程式碼相同,我想要學習的部分是透過陣列+字典物件的方式

原因是速度上似乎比較快

作者: PKKO 時間: 2015-9-16 20:03

回復 PKKO

Sub TEST_1()

.Clear: [J1] = ""
xRow = 10
arr = [A1].Resize(xRow)
Brr = [C1].R ...
ikboy 發表於 2015-9-16 09:42

感謝ikboy大大的回覆,您的INSTR方式小弟學習了

但想請教一下

您的方式雖有用到字典+陣列

但您跟我的一樣都是跑了雙重迴圈,假設2萬*2萬就會太久了

我實際將您的程式碼與我的測試,跑一萬次迴圈發現

您的程式碼速度與我的相差不到10 %

想請問有跑單迴圈的方式(類似我的TEST_1的程式碼)

可以加快比對速度嗎?

作者: ikboy 時間: 2015-9-16 20:47

回復 5# PKKO

單迴方法用在累加吧，但您目的是 sumif, count, 做雙迴像是必需，要再快的話要請其他大大指教了。

作者: 准提部林 時間: 2015-9-16 22:59

〔模糊比對〕，因有判斷式，大概一般都使用〔雙層迴圈〕，20000*20000=400000000，快不了！
要不，就要先將被比對文字〔拆分〕再納入〔字典檔〕，例如：1234 先拆成 1,2,3,4,12,23,34,123,234,1234，
以８個字元來說，每個編號要拆成３６個：=(字元數+1)/2*字元數，
故第一個迴圈為：20000*36=720000，再加第二迴圈20000，共跑 740000，
但這又脫離正規解法，參考即可：（附檔有三種模式，可比較看看）
　
程式碼：

Sub 取數3()
Dim i&, j&, Arr, Brr, Drr, T, SS, xD, xD1, TT$, M%, N%, Y$
T = Timer
[B:B].ClearContents: [H3:H4] = ""
Arr = [A1].Resize(R): Brr = [B1].Resize(R): Drr = [D1].Resize(R)
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
For j = 1 To UBound(Drr)
　　TT = Drr(j, 1)
　　M = Len(TT)
　　N = 1
　　xD1.RemoveAll
　　Do
　　　For i = 1 To M
　　　　　Y = Mid(TT, N, i)
　　　　　If xD1(Y) = "" Then xD(Y) = xD(Y) + 1
　　　　　xD1(Y) = 1
　　　Next i
　　　N = N + 1: M = M - 1
　　Loop Until M = 0
Next j
　
For i = 1 To UBound(Arr)
　　Y = Arr(i, 1): j = xD(Y)
　　Brr(i, 1) = j
　　SS = SS + j
Next i
　
[B1].Resize(R) = Brr: [H3] = Timer - T: [H4] = SS
End Sub

複製代碼

　
附檔下載：
[attach]22008[/attach]
　

作者: ikboy 時間: 2015-9-17 07:01

回復 7# 准提部林

多謝准大, 這讓我回看到我的程序中有漏洞,我被預設答案誘去調用了字典,但當C列有重覆時便會算漏,還是GBKEE版大和PKKO先進的方法準確。

作者: stillfish00 時間: 2015-9-17 10:14

回復 1# PKKO
不用 Like , 用 Filter

Sub Test()
Dim Arr, Brr, arFilter
Dim dArr As Object
Dim xRow : xRow = 10
Arr = [A1].Resize(xRow)
Brr = Application.Transpose([C1].Resize(xRow).Value)
Set dArr = CreateObject("Scripting.Dictionary")
For Each x In Arr
If Not dArr.exists(x) Then
arFilter = Filter(Brr, x) 'lbound index = 0
dArr.Add x, UBound(arFilter) - LBound(arFilter) + 1 'count
End If
Next
For i = 1 To UBound(Arr)
Arr(i, 1) = dArr(Arr(i, 1))
Next
[B1].Resize(UBound(Arr)) = Arr
End Sub

複製代碼

作者: ikboy 時間: 2015-9-17 10:59

回復 9# stillfish00

stillfish00大大, 這招高

作者: PKKO 時間: 2015-9-18 01:28

回復 7# 准提部林

感謝准提部林大大的回覆,讓我學習了您的思考邏輯方式,以及不同的程式撰寫方式!

作者: PKKO 時間: 2015-9-18 01:40

回復 9# stillfish00

感謝stillfish00大大,一路走來指導許多程式碼

這次您又幫了我大忙了,一直在思考怎樣可以讓程式跑得更快

您的程式碼速度快且撰寫快速,感恩哦~

作者: 准提部林 時間: 2015-9-18 10:49

回復 11# PKKO

Filter與一般函數相同，遇大迴圈還是要耗些時間：
Sub Test_Filter()
Dim i&, Arr(3000), Brr, T
For i = 0 To 3000: Arr(i) = i + 1: Next i
T = Timer
　
For i = 1 To 5000: Brr = Filter(Arr, i): Next i
MsgBox Timer - T
End Sub
　
但比起雙迴圈已快很多，是不錯的方法～～
　
若要比對方式為：
"A12*"　　"B315*"　〔開頭相同〕　或　"*256"　"*21"　〔結尾相同〕，還是用 Like，
Instr則可判斷關鍵字在文字串中的位置，也是常用語法～～

程式依資料多寡．型態及結構，使用適宜即可，無好壞之分～～
　

作者: PKKO 時間: 2015-9-18 18:33

回復 13# 准提部林

原來如此,感謝大大!

您提供的程式碼,我都有用到哦!!

但撰寫的時候總是要思考一下,還無法很順暢,所以都會回來偷看大大您寫的程式碼^_^

作者: Andy2483 時間: 2023-5-9 14:10

回復 7# 准提部林

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

執行結果:
[attach]36319[/attach]

Public Const R = 1000
Sub 取數3()
Dim i&, j&, Arr, Brr, Drr, T, SS, xD, xD1, TT$, M%, N%, Y$
'↑宣告變數
T = Timer
[B:B].ClearContents: [H3:H4] = ""
'↑清除結果欄舊資料
Arr = [A1].Resize(R):  Brr = [B1].Resize(R):  Drr = [D1].Resize(R)
'↑令(Arr,Brr,Drr)各是二維陣列帶入儲存格值
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
'↑令(xD,xD1)各是字典
For j = 1 To UBound(Drr)
'↑設順迴圈
TT = Drr(j, 1)
'↑令TT變數是迴圈Drr陣列值
M = Len(TT)
'↑令M變數是 TT變數的字數
N = 1
'↑令N變數是 1
xD1.RemoveAll
'↑令清空 xD1字典
Do
'↑設條件迴圈
   For i = 1 To M
   '↑設順迴圈
      Y = Mid(TT, N, i)
      '↑令Y是 TT變數從第1字開始取右側的字
      If xD1(Y) = "" Then xD(Y) = xD(Y) + 1
      '↑如果xD1字典裡沒有Y變數這key,就令xD字典納入,item累加1
      xD1(Y) = 1
      '↑令Y變數納入xD1字典裡,item是 1,讓xD1字典在下次清空前濾重複
   Next i
   N = N + 1: M = M - 1
   '↑N.M變數做變化,以全部文字串組合逐次擷取
Loop Until M = 0
'↑執行到最後一個字元
Next j
For i = 1 To UBound(Arr)
'↑設順迴圈
Y = Arr(i, 1): j = xD(Y)
'↑以Arr陣列值查xD字典回傳item值(該key出現過幾次)
Brr(i, 1) = j
'↑寫入Brr陣列
SS = SS + j
'↑累計次數
Next i
[B1].Resize(R) = Brr:  [H3] = Timer - T: [H4] = SS
End Sub

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)