- 帖子
- 1447
- 主題
- 40
- 精華
- 0
- 積分
- 1471
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2025-5-5
|
15#
發表於 2023-5-9 14:10
| 只看該作者
回復 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 |
|
發表於 2015-9-18 10:49
| 
