返回列表 上一主題 發帖

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

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

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

不好意思,麻煩各位大大了,我覺得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. Sub TEST_2()
  17. '我想將TEST_1模組的程式碼改成用LIKE的方式,不曉得該怎麼做???


  18. '我只會下列這種方式
  19. xRow = 10
  20. Arr = [A1].Resize(xRow)
  21. Brr = [C1].Resize(xRow)
  22. Dim AA
  23. ReDim AA(1 To 10, 1 To 1)
  24. For i = 1 To UBound(Arr)
  25.     M = 0
  26.     For J = 1 To UBound(Brr)
  27.         If Brr(J, 1) Like "*" & Arr(i, 1) & "*" Then
  28.             M = M + 1
  29.             AA(i, 1) = M
  30.         End If
  31.     Next
  32. Next
  33. [B1].Resize(xRow) = AA
  34. End Sub
複製代碼

TEST.rar (13.04 KB)

PKKO

回復 7# 准提部林


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

執行結果:



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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

回復 13# 准提部林


    原來如此,感謝大大!

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

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

TOP

回復 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則可判斷關鍵字在文字串中的位置,也是常用語法∼∼

程式依資料多寡.型態及結構,使用適宜即可,無好壞之分∼∼
 

TOP

回復 9# stillfish00


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

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

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

TOP

回復 7# 准提部林


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

TOP

回復 9# stillfish00


    stillfish00大大, 這招高

TOP

回復 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
複製代碼
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

回復 7# 准提部林


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

TOP

〔模糊比對〕,因有判斷式,大概一般都使用〔雙層迴圈〕,20000*20000=400000000,快不了!
要不,就要先將被比對文字〔拆分〕再納入〔字典檔〕,例如:1234 先拆成 1,2,3,4,12,23,34,123,234,1234,
以8個字元來說,每個編號要拆成36個:=(字元數+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)
 

TOP

        靜思自在 : 要用心,不要操心、煩心。
返回列表 上一主題