GBKEE

¦^´_ 1# kasl

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim D As Object, AR(), i, S, xMax  As Double, xMin  As Double
   
4.     Set D = CreateObject("SCRIPTING.DICTIONARY") '¦r¨åª«¥ó
   
5.     With Sheets("¶i³õ°O¿ýªí")
   
6.         i = 3   '±qA3 ¶}©l
   
7.         S = 0
   
8.         Do While .Cells(i, "A") <> ""
   
9.            D(Mid(.Cells(i, "A"), 1, 6)) = "" '«e6¦ì: ¦~¥÷¤ë¥÷
   
10.            ReDim Preserve AR(0 To S)
    
11.            AR(S) = .Cells(i, "A")
    
12.            If Mid(.Cells(i, "A"), 1, 6) <> Mid(.Cells(i + 1, "A"), 1, 6) Then
    
13.                 xMax = Application.WorksheetFunction.Large(AR, 1)
    
14.                 xMin = Application.WorksheetFunction.Small(AR, 1)
    
15.                 D(Mid(.Cells(i, "A"), 1, 6)) = Array(Mid(.Cells(i, "A"), 1, 6), xMin, xMax)
    
16.                 S = 0
    
17.             Else
    
18.                 S = S + 1
    
19.             End If
    
20.             i = i + 1
    
21.         Loop
    
22.     End With
    
23.     With Sheets("Sheet1") '¥t¤@¤u§@ªí
    
24.         .Range("a1").Resize(D.Count, 3) = Application.Transpose(Application.Transpose(D.Items))
    
25.     End With
    
26. End Sub

½Æ»s¥N½X