«ç»ò§ìÀx¦s®æ¸Ì"¯S§Oªº¤é´Á"

kasl

¤p§Ì·Q­n§ì¨úsheet¸Ì ¨C­Ó¤ë²Ä¤@­Ó¤é´Á¥H¤Î³Ì«á¤@­Ó¤é´Á
¨Ã¦s¨ì°}¦C¸Ì ½Ð°Ý³o­Ó¸Ó«ç»ò¼g
ÁÂÁÂ~

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

kasl

·PÁÂ~ ¤p§Ì¨Ó¬ã¨s¤@¤U¾ã­Óµ{¦¡ªº¹B§@¹Lµ{

Andy2483

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

¸ê®Æªí:

¤U¸ü (97.03 KB)

2023-4-18 15:46

µ²ªGªí:

¤U¸ü (122.21 KB)

2023-4-18 15:47

Option Explicit
Sub TEST()
Dim Brr, Y, R&, R1&, i&, T$, Tm$, xR As Range
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([C2], Cells(Rows.Count, "A").End(xlUp)): Brr = xR
For i = 2 To UBound(Brr)
   If i = 2 Then
      R = R + 1: Brr(1, 1) = "¤ë¥÷": Brr(1, 2) = "³Ì¦­¤é´Á": Brr(1, 3) = "³Ì«á¤é´Á"
   End If
   T = Brr(i, 1): Tm = Val(Brr(i, 1)) \ 100
   If Y(Tm) = "" Then
      R = R + 1: R1 = R: Y(Tm) = R1
      Brr(R1, 1) = Tm: Brr(R1, 2) = T: Brr(R1, 3) = T
      Else
         R1 = Y(Tm)
         If T < Brr(R1, 2) Then Brr(R1, 2) = T
         If T > Brr(R1, 3) Then Brr(R1, 3) = T
   End If
Next
With Workbooks.Add
   .Sheets(1).[A1].Resize(R, 3) = Brr
End With
Set Y = Nothing: Set xR = Nothing: Erase Brr
End Sub