ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

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

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

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

¶i³õ°O¿ýªí.rar (17.23 KB)

¤pµæ³¾¤@­Ó ½Ð¦h«ü±Ð~

¦^´_ 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
·P®¦ªº¤ß......(¦b³Â»¶®a±Ú°Q½×°Ï.¥Î¤ß¾Ç²ß·|¦³¶i¨Bªº)
¦ý¸ê·½µL­­,«á´©¦³­­,  ¤@¤Ñ1¤¸ªºÃÙ§U,¤H¤H¦³¯à¤O.

TOP

·PÁÂ~ ¤p§Ì¨Ó¬ã¨s¤@¤U¾ã­Óµ{¦¡ªº¹B§@¹Lµ{
¤pµæ³¾¤@­Ó ½Ð¦h«ü±Ð~

TOP

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

¸ê®Æªí:


µ²ªGªí:



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
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

        ÀR«ä¦Û¦b : ¤ß¤¤±`¦sµ½¸Ñ¡B¥]®e¡B·P«ä¡Bª¾¨¬¡B±¤ºÖ¡C
ªð¦^¦Cªí ¤W¤@¥DÃD