麻辣家族討論版版 » Excel程式區 » 如何使用陣列+字典物件比對資料的時候用LIKE語法?

PKKO 發表於 2015-9-16 08:19

如何使用陣列+字典物件比對資料的時候用LIKE語法?

[i=s] 本帖最後由 PKKO 於 2015-9-16 08:20 編輯 [/i]

不好意思,麻煩各位大大了,我覺得TEST_1的程式碼執行速度較快,但我只會用TEST_2的方式,有大大可以教學一下嗎?[code]
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
[/code]

GBKEE 發表於 2015-9-16 09:28

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=82026&ptid=15096]1#[/url] [i]PKKO[/i] [/b]
試試看[code]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
[/code]

ikboy 發表於 2015-9-16 09:42

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=82026&ptid=15096]1#[/url] [i]PKKO[/i] [/b]


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

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=82033&ptid=15096]2#[/url] [i]GBKEE[/i] [/b]


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

原因是速度上似乎比較快

PKKO 發表於 2015-9-16 20:03

[quote]回復  PKKO


Sub TEST_1()

.Clear: [J1] = ""
xRow = 10
arr = [A1].Resize(xRow)
Brr = [C1].R ...
[size=2][color=#999999]ikboy 發表於 2015-9-16 09:42[/color] [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=82035&ptid=15096][img]http://forum.twbts.com/images/common/back.gif[/img][/url][/size][/quote]

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

但想請教一下

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

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

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

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

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

可以加快比對速度嗎?

ikboy 發表於 2015-9-16 20:47

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=82071&ptid=15096]5#[/url] [i]PKKO[/i] [/b]


    單迴方法用在累加吧，但您目的是 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，
但這又脫離正規解法，參考即可：（[b]附檔有三種模式，可比較看看[/b]）
　
程式碼：[code]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[/code]　
附檔下載：
[attach]22008[/attach]
　

ikboy 發表於 2015-9-17 07:01

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=82076&ptid=15096]7#[/url] [i]准提部林[/i] [/b]


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

stillfish00 發表於 2015-9-17 10:14

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=82026&ptid=15096]1#[/url] [i]PKKO[/i] [/b]
不用 Like , 用 Filter[code]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[/code]

ikboy 發表於 2015-9-17 10:59

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=82088&ptid=15096]9#[/url] [i]stillfish00[/i] [/b]


    stillfish00大大, 這招高

PKKO 發表於 2015-9-18 01:28

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=82076&ptid=15096]7#[/url] [i]准提部林[/i] [/b]


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

PKKO 發表於 2015-9-18 01:40

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=82088&ptid=15096]9#[/url] [i]stillfish00[/i] [/b]


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

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

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

准提部林 發表於 2015-9-18 10:49

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=82109&ptid=15096]11#[/url] [i]PKKO[/i] [/b]


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

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=82119&ptid=15096]13#[/url] [i]准提部林[/i] [/b]


    原來如此,感謝大大!

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

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

Andy2483 發表於 2023-5-9 14:10

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=82076&ptid=15096]7#[/url] [i]准提部林[/i] [/b]


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

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


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

查看完整版本: 如何使用陣列+字典物件比對資料的時候用LIKE語法?