- 帖子
- 1447
- 主題
- 40
- 精華
- 0
- 積分
- 1471
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2025-3-24
|
本帖最後由 Andy2483 於 2023-4-19 14:42 編輯
謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教
資料表:
執行結果("最大值" 工作表):
執行結果("最小值" 工作表):
Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 100, 1 To 7), Y, R1&, R2&, i&, T, P$, Min&, Max&
Dim xR As Range, Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet
Set Y = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("資料"): Set Sh2 = Sheets("最大值"): Set Sh3 = Sheets("最小值")
Sh2.UsedRange.Delete: Sh3.UsedRange.Delete
Set xR = Range(Sh1.[O3], Sh1.Cells(Rows.Count, "I").End(xlUp)): Brr = xR
For i = 1 To UBound(Brr)
T = Val(Brr(i, 3)): Y(T & "|" & i) = i
If IsEmpty(Min) Or Min > T Then Min = T
If IsEmpty(Max) Or T > Max Then Max = T
Next
For Each T In Y.keys
If Val(T) = Max Then
R1 = R1 + 1: For i = 1 To 7: Brr(R1, i) = Brr(Y(T), i): Next
End If
If Val(T) = Min Then
R2 = R2 + 1: For i = 1 To 7: Crr(R2, i) = Brr(Y(T), i): Next
End If
Next
Sh2.[A1].Resize(R1, 7) = Brr: Sh3.[A1].Resize(R2, 7) = Crr
Set Y = Nothing: Set xR = Nothing: Erase Brr, Crr
Set Sh1 = Nothing: Set Sh2 = Nothing: Set Sh3 = Nothing
End Sub |
|
發表於 2023-4-19 14:41
| 