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

[µo°Ý] ¦p¦óÅýÁ`ªíÂà¤Æ¬°¤T±i©ú²Óªí

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

Option Explicit
'³o¤è®×¬O¥H¦r¨åkey°O¿ý¤£­«½Æªº³f¸¹,item¬°¤Gºû°}¦C,
'¥t¥H³f¸¹³s±µ"/r"¦r¦ê¬°key,item¬°¸Ó¤Gºû°}¦C¤w¨Ï¥Îªº¦C¼Æ

Sub TEST_2()
Application.DisplayAlerts = False
Dim Brr, Crr(1 To 1000, 1 To 8), Z, Q, A, R&, i&, j%, s%, N%
Set Z = CreateObject("Scripting.Dictionary")
For Each A In Worksheets
   If A.Name <> "Á`ªí" Then A.Delete
Next
Brr = [A1].CurrentRegion
For i = 3 To UBound(Brr)
   A = Z(Brr(i, 2)): R = Z(Brr(i, 2) & "/r") + 1
   '°j°é¤@¶}©l:
   'A = Z(Brr(i, 2))³oµ{§Ç°õ¦æ´N¤w¸g¦bZ¦r¨å¸Ì²£¥Í¤Fkey¬O Brr(i, 2)°}¦C­È,
   '¦Ó³o¹ïÀ³item¬OªÅªº,µ{§Ç·N¸q¬O¥O¥HAÅܼƬO °j°é³f¸¹¬°key±Nitem¤Gºû°}¦C´£¨ú¥X¨Ó,
   '¦pªGitem¤£¬O¤Gºû°}¦C¤]¨S®t!
   '¦]¬°AÅܼƫŧiªº¬O³q¥Î«¬ÅܼÆ,¥i¥HÀH»Ý¨D§@ÅÜ´«(²¦³º¤@¶}©lªº¦r¨å¸Ì­þ¨Óªº¤Gºû°}¦C)
   
   'R = Z(Brr(i, 2) & "/r") + 1³oµ{§Ç°õ¦æ«á¤w¸g´N¤w¸g¦bZ¦r¨å¸Ì²£¥Í¤Fkey¬O
   'Brr(i, 2)°}¦C­È³s±µ"/r"·s¦r¦ê,¦Ó³o¹ïÀ³item +1,µ{§Ç·N¸q¬O:
   '¥ORÅܼƬO ³f¸¹³s±µ"/r"¦r¦êªºkey,item¬O¦Û¨­­È+1(³o¬O­n¼g¤J¤Gºû°}¦CªºªÅ¦C¸¹)
   '¦Ü¦¹·|¦³­ÓºÃ°Ý,AÅܼƳ£ÁÙ¤£¬O°}¦C! ­þ¸Ì¨ÓªºªÅ¦C??
   'AÅܼÆÁÙ¤£¬O°}¦C¤]¨S®t,«á¤èµ{§Ç§PÂ_¦¡·|«Ø¥ß·s¤Gºû°}¦C,
   'RÅܼƫŧiªº¬O ªø¾ã¼Æ,¨äªì©l­È¬O0,¦A+1=1,©Ò¥H­è¦n«ü©w¨ä­n¼g¤JªÅ¦C¸¹¬O²Ä1¦C

      
   If Not IsArray(A) Then A = Crr
   '¡ô¦pªGAÅܼƤ£¬O°}¦C,´N¥OA¬O¦PCrrÅܼƪº¤Gºû°}¦C
   '¦Ü¦¹¨C­Ói°j°é³£¥H³f¸¹·íkey,item¬O¸Ëµ²ªG¸ê®Æªº¤Gºû°}¦C,³f¸¹³s±µ"/r"¦r¦ê°O¿ý¸Ó
   '¤Gºû°}¦C¥Î¨ì­þ¤@¦C¤F

   For j = 1 To 8: A(R, j) = Brr(i, j): Next
   Z(Brr(i, 2)) = A: Z(Brr(i, 2) & "/r") = R
Next
'¡ôÂǵ۱N¤Gºû°}¦C¦bitem¸m¤J/´£¨ú/½s¿è/©ñ¦^¹F¨ì¥Øªº,¦Ü©ó¬°¦ó­n´£¨ú¥X¨Ó¦A½s¿è?
'VBA³W«h:¦r¨å¸Ìªº°}¦C­n½s¿è»Ý´£¨ú¥X¨Ó¦A©ñ¦^,µLªkª½±µ¦b¦r¨å¸Ì½s¿è

For Each A In Z.keys
   If Not IsArray(Z(A)) Then GoTo A01
   Worksheets.Add.Name = A
   [A1:H1].Resize(2) = Brr
   [A3].Resize(Z(A & "/r"), 8) = Z(A)
A01: Next
'¡ô³]³v¶µ°j°é±N¦r¨å¸Ìªº¤Gºû°}¦C¼g¤J·s¼W¤u§@ªí¸Ì
End Sub
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

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

Option Explicit
'³o¤è®×¬O¥H¦r¨åkey°O¿ý¤£­«½Æªº³f¸¹,item¬°Àx¦s®æ¶°
Sub TEST_3()
Application.DisplayAlerts = False
Dim Brr, A, Z, Q, i&, T$
Set Z = CreateObject("Scripting.Dictionary")
For Each A In Worksheets
   If A.Name <> "Á`ªí" Then A.Delete
Next
Brr = [A1].CurrentRegion
For i = 3 To UBound(Brr)
   T = Brr(i, 2)
   If Not IsObject(Z(T)) Then
      Set Z(T) = Union([A1:A2], Cells(i, 2))
      Else
      Set Z(T) = Union(Z(T), Cells(i, 2))
   End If
Next
For Each Q In Z.keys
   Worksheets.Add.Name = Q
   Z(Q).EntireRow.Copy [A1]
Next
End Sub
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

        ÀR«ä¦Û¦b : °ß¨ä´L­«¦Û¤vªº¤H¡A¤~§ó«i©óÁY¤p¦Û¤v¡C
ªð¦^¦Cªí ¤W¤@¥DÃD