Sub 執行這個()
Sheets("工作表_1").Range("F:k").ClearContents
test
test2
End Sub
Sub test()
Dim v As String, ve As String
sr = Split("工作表_3,工作表_4,工作表_7", ",")
Set d = CreateObject("scripting.dictionary")
Set s = Sheets("工作表_1")
r = s.Cells(Rows.Count, 1).End(3).Row
For i = 1 To r
v = s.Cells(i, 1).Value: ve = Left(v, 1)
If d.exists(ve) = False Then Set d(ve) = CreateObject("scripting.dictionary")
d(ve)(v) = s.Cells(i, 1).Row
Next
ReDim ar(1 To r, 0 To 2) As String
For h = 0 To 2
Set s = Sheets(sr(h))
r = s.Cells(Rows.Count, 1).End(3).Row
For i = 1 To r
ve = s.Cells(i, 1).Value
ar(d(Left(ve, 1))(ve), h) = s.Cells(i, 3).Value
Next
Next
Sheets("工作表_1").Cells(1, 6).Resize(r, 3) = ar
End Sub
Sub test2()
Dim v As String, ve As String
sr = Split("工作表_2,工作表_5,工作表_6", ",")
Set d = CreateObject("scripting.dictionary")
Set s = Sheets("工作表_1")
r = s.Cells(Rows.Count, 4).End(3).Row
For i = 1 To r
v = s.Cells(i, 4).Value: ve = Left(v, 1)
If d.exists(ve) = False Then Set d(ve) = CreateObject("scripting.dictionary")
d(ve)(v) = s.Cells(i, 4).Row
Next
ReDim ar(1 To r, 0 To 2) As String
For h = 0 To 2
Set s = Sheets(sr(h))
r = s.Cells(Rows.Count, 1).End(3).Row
For i = 1 To r
ve = s.Cells(i, 1).Value
ar(d(Left(ve, 1))(ve), h) = s.Cells(i, 3).Value
Next
Next
Sheets("工作表_1").Cells(1, 9).Resize(r, 3) = ar
End Sub
以下學習到的心得註解一下! 如有冒犯請見諒!
請前輩指正並再指導! 謝謝
Option Explicit
Sub 執行這個()
Dim T
'↑宣告變數
T = Timer
'↑令T是當下時間 @2
Sheets("工作表_1").Range("F:k").ClearContents
'↑清除表_1 "F:k"欄位儲存格內容
Call test
'↑執行副程式 test()
Call test2
'↑執行副程式 test2()
MsgBox Timer - T & " 秒"
'↑跳出提示窗!顯示 最後時間 - 剛剛的 當下時間 @2
End Sub
Sub test()
Dim v As String, ve As String, sr, d, S, r, i, h, rr
'↑宣告變數
sr = Split("工作表_3,工作表_4,工作表_7", ",") '@1
'↑令 sr是一維陣列!3個將被搜尋的資料表名稱以","符號分個割 倒入sr
'這是要被 工作表_1(以下稱表_1) A欄搜尋取對應值的3個工作表!
Set d = CreateObject("scripting.dictionary")
'↑令d是字典
Set S = Sheets("工作表_1")
'↑令s 是物件 "表_1" 工作表
r = S.Cells(Rows.Count, 1).End(3).Row
'↑令r是表_1 A欄有內容的儲存格最後一列數
For i = 1 To r
'↑設順迴圈從1 到 A欄有內容的儲存格最後一列數
v = S.Cells(i, 1).Value
'↑令v是 表_1 的迴圈A欄儲存格值
ve = Left(v, 1)
'↑令ve 是 A欄儲存格值的最左邊的字元
If d.exists(ve) = False Then
'↑如果d字典裡沒有這個字元的key
Set d(ve) = CreateObject("scripting.dictionary")
'↑若條件成立!就將此字元為key,item是一個d字典中的字典
End If
d(ve)(v) = S.Cells(i, 1).Row
'↑令 d字典中的字典 d(ve)倒入 A欄儲存格值為key!儲存格列位為item
Next
ReDim ar(1 To r, 0 To 2) As String
'↑宣告字串ar 陣列的縱向範圍是1 到 表_1 A欄有內容的儲存格最後一列數
'橫向範圍是0 到2
For h = 0 To 2
'↑設外順迴圈從0 到2
Set S = Sheets(sr(h))
'↑令s是 被搜尋的資料表 @1
rr = S.Cells(Rows.Count, 1).End(3).Row
'↑令rr是 被搜尋表 A欄有內容的儲存格最後一列數
For i = 1 To rr
'↑設內順迴圈從1 到被搜表 A欄有內容的儲存格最後一列數
ve = S.Cells(i, 1).Value
'↑令ve是被搜表 的迴圈A欄儲存格值(關鍵字)
ar(d(Left(ve, 1))(ve), h) = S.Cells(i, 3).Value
'↑以 被搜表關鍵字最左邊字元為key 查察d字典中對應的item字典
',這以字首為名(key)的字典中字典,以被搜表關鍵字查察對應的列數(表_1),
'為ar陣列的列位,h是該關鍵字搜尋到值的指定欄位
'↑也就是把 被搜表關鍵字搜尋到的值 放到字典記錄的ar陣列列位中
Next
Next
Sheets("工作表_1").Cells(1, 6).Resize(r, 3) = ar
'↑將 ar陣列的值從表_1的[F1]開始貼入
End Sub
Sub test2()
Dim v As String, ve As String, sr, d, S, r, i, h, rr
'↑宣告變數
sr = Split("工作表_2,工作表_5,工作表_6", ",")
'↑令 sr是一維陣列!3個將被搜尋的資料表名稱以","符號分個割 倒入sr
'這是要被 工作表_1(以下稱表_1) D欄搜尋取對應值的3個工作表!
Set d = CreateObject("scripting.dictionary")
'↑令d是字典
Set S = Sheets("工作表_1")
'↑令s 是物件 表_1 工作表
r = S.Cells(Rows.Count, 4).End(3).Row
'↑令r是表_1 D欄有內容的儲存格最後一列數
For i = 1 To r
'↑設順迴圈從1 到 D欄有內容的儲存格最後一列數
v = S.Cells(i, 4).Value
'↑令v是 表_1 的迴圈D欄儲存格值
ve = Left(v, 1)
'↑令ve 是 D欄儲存格值的最左邊的字元
If d.exists(ve) = False Then
'↑如果d字典裡沒有這個字元的key
Set d(ve) = CreateObject("scripting.dictionary")
'↑若條件成立!就將此字元為key,item是一個d字典中的字典
End If
d(ve)(v) = S.Cells(i, 4).Row
'↑令 d字典中的字典 d(ve)倒入 D欄儲存格值為key!儲存格列位為item
Next
ReDim ar(1 To r, 0 To 2) As String
'↑宣告字串ar 陣列的縱向範圍是1 到 表_1 D欄有內容的儲存格最後一列數
'橫向範圍是0 到2
For h = 0 To 2
'↑設外順迴圈從0 到2
Set S = Sheets(sr(h))
'↑令s是 被搜尋的資料表 @1
rr = S.Cells(Rows.Count, 1).End(3).Row
'↑令rr是 被搜尋表 A欄有內容的儲存格最後一列數
For i = 1 To rr
'↑設內順迴圈從1 到被搜表 A欄有內容的儲存格最後一列數
ve = S.Cells(i, 1).Value
'↑令ve是被搜表 的迴圈A欄儲存格值(關鍵字)
ar(d(Left(ve, 1))(ve), h) = S.Cells(i, 3).Value
'↑以 被搜表關鍵字最左邊字元為key 查察d字典中對應的item字典
',這以字首為名(key)的字典中字典,以被搜表關鍵字查察對應的列數(表_1),
'為ar陣列的列位,h是該關鍵字搜尋到值的指定欄位
'↑也就是把 被搜表關鍵字搜尋到的值 放到字典記錄的ar陣列列位中
Next
Next
Sheets("工作表_1").Cells(1, 9).Resize(r, 3) = ar
'↑將 ar陣列的值從表_1的[I1]開始貼入
End Sub作者: 准提部林 時間: 2022-10-28 15:00
Sub TEST_A1()
Dim Arr, Brr, Crr, Sn, T$, xD, R1&, R2&, Rx&, i&, j%, c%
Set xD = CreateObject("scripting.dictionary")
R1 = [工作表_1!A65536].End(xlUp).Row
R2 = [工作表_1!D65536].End(xlUp).Row
Rx = R1: If R2 > R1 Then Rx = R2
Arr = Sheets("工作表_1").Range("A1:D" & Rx)
For i = 1 To Rx
If Arr(i, 1) <> "" Then xD(Arr(i, 1) & "/A") = i
If Arr(i, 4) <> "" Then xD(Arr(i, 4) & "/D") = i
Next i
ReDim Crr(1 To Rx, 1 To 6)
For Each S In Split("工作表_3/工作表_4/工作表_7/工作表_2/工作表_5/工作表_6", "/")
R1 = Sheets(S & "").[a65536].End(xlUp).Row
Brr = Sheets(S & "").Range("A1:C" & R1)
c = c + 1
T = IIf(c > 3, "/D", "/A")
For i = 1 To R1
R2 = xD(Brr(i, 1) & T)
If R2 > 0 Then Crr(R2, c) = Brr(i, 3)
Next i
Next S
Sheets("工作表_1").[f1].Resize(Rx, 6) = Crr
End Sub
