Option Explicit
Sub TEST()
Dim Arr, Brr, Crr, V, Z, i&, j%, R&, T$, TT$, xS As Worksheet
Set Z = CreateObject("Scripting.Dictionary")
Brr = [日期!A1].CurrentRegion: Set xS = Sheets("提取資料"): xS.UsedRange.Offset(1).EntireRow.Delete
For i = 2 To UBound(Brr)
T = Brr(i, 8): V = Brr(i, 15): TT = i & "^0*" & Val(V)
If Not Z.EXISTS(T) Then Z(T) = TT Else Z(T) = IIf(Val(V) > Evaluate(Z(T)), TT, Z(T))
Next
ReDim Arr(1 To UBound(Brr), 1 To UBound(Brr, 2)): Crr = [參照數值!A1].CurrentRegion
For i = 2 To UBound(Crr)
T = Crr(i, 1): Crr(i, 1) = ""
If Not Z.EXISTS(T) Then
Arr(i - 1, 1) = "NA": Crr(i, 1) = "NA": Arr(i - 1, 8) = T
Else
R = Split(Z(T), "^")(0): For j = 1 To UBound(Brr): Arr(i - 1, j) = Brr(R, j): Next
End If
Next
With Sheets("參照數值")
.UsedRange.Offset(, 1).EntireColumn.Delete
.[B1].Resize(UBound(Crr)) = Crr: .[B1] = "NA註記"
End With
With xS.[A2].Resize(UBound(Crr) - 1, UBound(Arr, 2))
.Value = Arr: Application.Goto xS.[A1]
.Columns(2).NumberFormat = "hh:mm:ss"
End With
End Sub作者: hcm19522 時間: 2024-3-15 10:09
Option Explicit
Sub TEST_1()
Dim Arr, Brr, V, Q, Z, i&, j%, N&, a%, xS As Worksheet
Set Z = CreateObject("Scripting.Dictionary")
Brr = [日期!A1].CurrentRegion: Set xS = Sheets("提取資料"): xS.UsedRange.Offset(1).EntireRow.Delete
For i = 2 To UBound(Brr)
V = Brr(i, 15): V = Val(V)
If Not Z.EXISTS(V) Then Z(V) = i Else Z(V) = Z(V) & "/" & i
Next
ReDim Arr(1 To UBound(Brr), 1 To UBound(Brr, 2) + 1)
For i = 1 To 10
Q = Application.Large(Z.keys, i)
V = Split("/" & Z(Q), "/")
For a = 1 To UBound(V)
N = N + 1: Arr(N, 1) = i: For j = 1 To UBound(Brr, 2): Arr(N, j + 1) = Brr(Val(V(a)), j): Next
Next
Next
With xS.[A2].Resize(N, UBound(Arr, 2))
.Value = Arr: Application.Goto xS.[A1]: .Columns(3).NumberFormat = "hh:mm:ss"
End With
End Sub作者: GGGYYY 時間: 2024-3-15 21:16
Option Explicit
Sub TEST()
Dim Arr, Brr, Crr, V, Z, i&, j%, R&, T$, TT$, xS As Worksheet
'↑宣告變數:&是長整數,$是字串變數,%是短整數,沒有指定的是通用型變數
Set Z = CreateObject("Scripting.Dictionary")
'↑令Z變數是 字典
Brr = [日期!A1].CurrentRegion: Set xS = Sheets("提取資料"): xS.UsedRange.Offset(1).EntireRow.Delete
'↑令Brr變數是 以工作表儲存格值帶入的二維陣列,令xS變數是(物件)"提取資料"工作表
'令舊資料刪除,只留下標題列
For i = 2 To UBound(Brr)
'↑設順迴圈!i從2 到Brr陣列縱向最大索引列號
T = Brr(i, 8): V = Brr(i, 15): TT = i & "^0*" & Val(V)
'↑令T變數是i迴圈列8欄Brr陣列值,令V變數是i迴圈列15欄Brr陣列值
'令TT變數是迴圈數i 連接"^0*"字串,再連接V變數轉數值所組成的新字串
If Not Z.EXISTS(T) Then Z(T) = TT Else Z(T) = IIf(Val(V) > Evaluate(Z(T)), TT, Z(T))
'↑如果Z字典裡沒有T變數key!就令以T為key,item是TT變數納入Z字典中,
'否則就令以T為key,item是IIf()回傳值
Next
ReDim Arr(1 To UBound(Brr), 1 To UBound(Brr, 2)): Crr = [參照數值!A1].CurrentRegion
'↑宣告Arr變數是二維空陣列,宣告其陣列範圍,令Crr陣列是 以工作表儲存格值帶入的二維陣列
For i = 2 To UBound(Crr)
'↑設順迴圈!i從2 到Crr陣列縱向最大索引列號
T = Crr(i, 1): Crr(i, 1) = ""
'↑令T變數是i迴圈列1欄Crr陣列值,令i迴圈列1欄Crr陣列值是空字元
If Not Z.EXISTS(T) Then
'↑如果Z字典裡沒有T變數key??
Arr(i - 1, 1) = "NA": Crr(i, 1) = "NA": Arr(i - 1, 8) = T
'↑令找不到關鍵字列註記欄寫入"NA"字串
Else
R = Split(Z(T), "^")(0): For j = 1 To UBound(Brr, 2): Arr(i - 1, j) = Brr(R, j): Next
'↑令R變數是 Z字典記錄的列號!設順迴圈將Brr資料寫入Arr陣列裡
End If
Next
With Sheets("參照數值")
.UsedRange.Offset(, 1).EntireColumn.Delete
'↑令"參照數值"表只留下標題欄,其餘欄位刪除
.[B1].Resize(UBound(Crr)) = Crr: .[B1] = "NA註記"
'↑令B欄寫入"NA"註記
End With
With xS.[A2].Resize(UBound(Crr) - 1, UBound(Arr, 2))
'↑以下是關於"提取資料"表從[A2]儲存格擴展指定範圍儲存格的程序
.Value = Arr: Application.Goto xS.[A1]
'↑令Arr陣列值寫入 "提取資料"表,令游標跳到"提取資料"表[A1]儲存格
.Columns(2).NumberFormat = "hh:mm:ss"
'↑令該範圍第2欄格式為2碼時:分:秒
End With
End Sub
