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

PKKO

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

1. Sub TEST_1()
   
2. '這是原本的程式碼
   
3. [B:B].Clear: [J1] = ""
   
4. xRow = 10
   
5. Arr = [A1].Resize(xRow)
   
6. Brr = [C1].Resize(xRow)
   
7. Set xD = CreateObject("Scripting.Dictionary")
   
8. For i = 1 To UBound(Brr)
   
9.     xD(Brr(i, 1)) = xD(Brr(i, 1)) + 1
   
10. Next
    
11. For i = 1 To UBound(Arr)
    
12.     Arr(i, 1) = xD(Arr(i, 1))
    
13. Next
    
14. [B1].Resize(xRow) = Arr
    
15. End Sub
    
16. 
    
17. 
    
18. Sub TEST_2()
    
19. '我想將TEST_1模組的程式碼改成用LIKE的方式,不曉得該怎麼做???
    
20. 
    
21. 
    
22. '我只會下列這種方式
    
23. xRow = 10
    
24. Arr = [A1].Resize(xRow)
    
25. Brr = [C1].Resize(xRow)
    
26. Dim AA
    
27. ReDim AA(1 To 10, 1 To 1)
    
28. For i = 1 To UBound(Arr)
    
29.     M = 0
    
30.     For J = 1 To UBound(Brr)
    
31.         If Brr(J, 1) Like "*" & Arr(i, 1) & "*" Then
    
32.             M = M + 1
    
33.             AA(i, 1) = M
    
34.         End If
    
35.     Next
    
36. Next
    
37. [B1].Resize(xRow) = AA
    
38. End Sub

複製代碼

GBKEE

回復 1# PKKO
試試看

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

複製代碼

ikboy

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

回復 2# GBKEE


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

原因是速度上似乎比較快

PKKO

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

回復 5# PKKO


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

准提部林

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

1. Sub 取數3()
   
2. Dim i&, j&, Arr, Brr, Drr, T, SS, xD, xD1, TT$, M%, N%, Y$
   
3. T = Timer
   
4. [B:B].ClearContents: [H3:H4] = ""
   
5. Arr = [A1].Resize(R):  Brr = [B1].Resize(R):  Drr = [D1].Resize(R)
   
6. Set xD = CreateObject("Scripting.Dictionary")
   
7. Set xD1 = CreateObject("Scripting.Dictionary")
   
8. For j = 1 To UBound(Drr)
   
9. 　　TT = Drr(j, 1)
   
10. 　　M = Len(TT)
    
11. 　　N = 1
    
12. 　　xD1.RemoveAll
    
13. 　　Do
    
14. 　　　For i = 1 To M
    
15. 　　　　　Y = Mid(TT, N, i)
    
16. 　　　　　If xD1(Y) = "" Then xD(Y) = xD(Y) + 1
    
17. 　　　　　xD1(Y) = 1
    
18. 　　　Next i
    
19. 　　　N = N + 1: M = M - 1
    
20. 　　Loop Until M = 0
    
21. Next j
    
22. 　
    
23. For i = 1 To UBound(Arr)
    
24. 　　Y = Arr(i, 1): j = xD(Y)
    
25. 　　Brr(i, 1) = j
    
26. 　　SS = SS + j
    
27. Next i
    
28. 　
    
29. [B1].Resize(R) = Brr:  [H3] = Timer - T: [H4] = SS
    
30. End Sub

複製代碼

　
附檔下載：
模糊比對取數v01.rar (151.53 KB)

下載次數: 33

2015-9-16 22:59

　

ikboy

回復 7# 准提部林


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

stillfish00

回復 1# PKKO
不用 Like , 用 Filter

1. Sub Test()
   
2.     Dim Arr, Brr, arFilter
   
3.     Dim dArr As Object
   
4.     Dim xRow : xRow = 10
   
5.    
   
6.     Arr = [A1].Resize(xRow)
   
7.     Brr = Application.Transpose([C1].Resize(xRow).Value)
   
8.    
   
9.     Set dArr = CreateObject("Scripting.Dictionary")
   
10.    
    
11.     For Each x In Arr
    
12.         If Not dArr.exists(x) Then
    
13.             arFilter = Filter(Brr, x)   'lbound index = 0
    
14.             dArr.Add x, UBound(arFilter) - LBound(arFilter) + 1 'count
    
15.         End If
    
16.     Next
    
17.     For i = 1 To UBound(Arr)
    
18.         Arr(i, 1) = dArr(Arr(i, 1))
    
19.     Next
    
20.     [B1].Resize(UBound(Arr)) = Arr
    
21. End Sub

複製代碼

ikboy

回復 9# stillfish00


    stillfish00大大, 這招高