Board logo

標題: [發問] 請教如何讓vba自動判斷篩選最大值與最小值 [打印本頁]
作者: jonn0510    時間: 2014-10-22 05:53     標題: 請教如何讓vba自動判斷篩選最大值與最小值

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

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    時間: 2014-10-22 10:26

回復 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    時間: 2014-10-22 13:53

回復 3# GBKEE

GBKEE 老師:
您的方式，正是小弟所需要的，且您還幫忙做註解，讓我能更清楚如何運用，感謝您的指導，謝謝。
作者: jonn0510    時間: 2014-10-22 13:53

回復 2# rouber590324
rouber590324老師:
您的方式也是可行，只是不是小弟所需要用到的，但也感謝您願意撥空指導，謝謝
作者: Andy2483    時間: 2023-4-19 14:41

本帖最後由 Andy2483 於 2023-4-19 14:42 編輯

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

資料表:
[attach]36187[/attach]

執行結果("最大值" 工作表):
[attach]36188[/attach]

執行結果("最小值" 工作表):
[attach]36189[/attach]


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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)