PKKO

回復 7# 准提部林


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

PKKO

回復 9# stillfish00


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

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

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

准提部林

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

回復 13# 准提部林


    原來如此,感謝大大!

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

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

Andy2483

回復 7# 准提部林


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

執行結果:

下載 (67.59 KB)

2023-5-9 14:04

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