[發問] 請教如何讓vba自動判斷篩選最大值與最小值

jonn0510

請問老師:
如何讓VBA自動判斷篩選K3~K21的最大值,篩選後將篩選結果拷貝到最大值工作表A1的位置
再讓VBA自動判斷篩選K3~K21的最小值,篩選後將篩選結果拷貝到最小值工作表A1的位置。謝謝

rouber590324

dear sir
    如下試試     sheet1=source  
                  sheet2=最大值工作表
                              sheet3=最小值工作表
Sub AA()
Sheet1.Select
   mymax = Evaluate("max(K3:K21)")
   mymin = Evaluate("min(K3:K21)")
   Sheet2.Range("a1") = mymax
   Sheet3.Range("a1") = mymin
End Sub

GBKEE

回復 2# rouber590324
樓主應該是期望如此的

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim D As Object, Rng As Range, R As Range
   
4.     Dim xMax As Single, xMin As Single
   
5.     Set D = CreateObject("SCRIPTING.DICTIONARY")    '字典物件
   
6.     Set Rng = Sheets("資料").[I3:O21]               '資料範圍
   
7.     xMax = Application.Max(Rng.Columns(3))          '第3欄(k欄)的最大值
   
8.     xMin = Application.Min(Rng.Columns(3))          '第3欄(k欄)的最小值
   
9.     For Each R In Rng.Rows                          '資料範圍(物件)的列(物件)
   
10.         If R.Cells(3) = xMax Then                   '是最大值的數值
    
11.             If D.exists(xMax) Then                  '字典物件的key(關鍵字)是存在的
    
12.                 Set D(xMax) = Union(R, D(xMax))     'Union:兩個或多個範圍的合併範圍。
    
13.             Else
    
14.                 Set D(xMax) = R                     '設定範圍
    
15.             End If
    
16.         ElseIf R.Cells(3) = xMin Then               '是最小值的數值
    
17.             If D.exists(xMin) Then
    
18.                 Set D(xMin) = Union(R, D(xMin))
    
19.             Else
    
20.                 Set D(xMin) = R
    
21.             End If
    
22.         End If
    
23.     Next
    
24.     D(xMax).Copy Sheets("最大值").[a1]
    
25.     D(xMin).Copy Sheets("最小值").[a1]
    
26. End Sub

複製代碼

jonn0510

回復 3# GBKEE

GBKEE 老師:
您的方式，正是小弟所需要的，且您還幫忙做註解，讓我能更清楚如何運用，感謝您的指導，謝謝。

jonn0510

回復 2# rouber590324
rouber590324老師:
您的方式也是可行，只是不是小弟所需要用到的，但也感謝您願意撥空指導，謝謝

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教

資料表:

下載 (129.46 KB)

2023-4-19 14:38

執行結果("最大值" 工作表):

下載 (13.95 KB)

2023-4-19 14:39

執行結果("最小值" 工作表):

下載 (13.36 KB)

2023-4-19 14:40

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