Andy2483

回復 1# GGGYYY

謝謝前輩發表此主題與範例
後學藉此帖練習陣列.Evaluate()與 以字典記錄列號的方法,學習方案如下,請前輩參考
執行結果:

下載 (112.36 KB)

2024-3-15 09:09

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

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列.Large()與字典記錄列號,學習列出"日期"表O欄前10大值資料列
執行結果:

下載 (165.02 KB)

2024-3-15 13:56

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

Andy2483

回復 7# GGGYYY

謝謝前輩回復
後學糊塗,請修改如下試試看:
R = Split(Z(T), "^")(0): For j = 1 To UBound(Brr, 2): Arr(i - 1, j) = Brr(R, j): Next

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖複習修訂,學習心得如下,請各位前輩指教

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