GBKEE

¦^´_ 2# rouber590324
¼Ó¥DÀ³¸Ó¬O´Á±æ¦p¦¹ªº

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")    '¦r¨åª«¥ó
   
6.     Set Rng = Sheets("¸ê®Æ").[I3:O21]               '¸ê®Æ½d³ò
   
7.     xMax = Application.Max(Rng.Columns(3))          '²Ä3Äæ(kÄæ)ªº³Ì¤j­È
   
8.     xMin = Application.Min(Rng.Columns(3))          '²Ä3Äæ(kÄæ)ªº³Ì¤p­È
   
9.     For Each R In Rng.Rows                          '¸ê®Æ½d³ò(ª«¥ó)ªº¦C(ª«¥ó)
   
10.         If R.Cells(3) = xMax Then                   '¬O³Ì¤j­Èªº¼Æ­È
    
11.             If D.exists(xMax) Then                  '¦r¨åª«¥óªºkey(ÃöÁä¦r)¬O¦s¦bªº
    
12.                 Set D(xMax) = Union(R, D(xMax))     'Union:¨â­Ó©Î¦h­Ó½d³òªº¦X¨Ö½d³ò¡C
    
13.             Else
    
14.                 Set D(xMax) = R                     '³]©w½d³ò
    
15.             End If
    
16.         ElseIf R.Cells(3) = xMin Then               '¬O³Ì¤p­Èªº¼Æ­È
    
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("³Ì¤j­È").[a1]
    
25.     D(xMin).Copy Sheets("³Ì¤p­È").[a1]
    
26. End Sub

½Æ»s¥N½X