Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð

¸ê®Æªí:

¤U¸ü (129.46 KB)

2023-4-19 14:38

°õ¦æµ²ªG("³Ì¤j­È" ¤u§@ªí):

¤U¸ü (13.95 KB)

2023-4-19 14:39

°õ¦æµ²ªG("³Ì¤p­È" ¤u§@ªí):

¤U¸ü (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("³Ì¤j­È"): Set Sh3 = Sheets("³Ì¤p­È")
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