- ©«¤l
 - 1527 
 - ¥DÃD
 - 40 
 - ºëµØ
 - 0 
 - ¿n¤À
 - 1551 
 - ÂI¦W
 - 0  
 - §@·~¨t²Î
 - Windows  7 
 - ³nÅ骩¥»
 - Excel 2010 & 2016 
 - ¾\ŪÅv
 - 100 
 - ©Ê§O
 - ¨k 
 - ¨Ó¦Û
 - ¥xÆW 
 - µù¥U®É¶¡
 - 2020-7-15 
 - ³Ì«áµn¿ý
 - 2025-11-4 
 
  | 
                
 ¥»©«³Ì«á¥Ñ Andy2483 ©ó 2022-12-21 10:32 ½s¿è  
 
¦^´_ 4# jsc0518  
 
 
    ÁÂÁ«e½ú¦^´_ 
¤µ¤Ñ¦A½Æ²ß¤F¤@¤U,ÅÞ¿è§ó²M·¡,¤]µo²{¤@¨Ç¯Êº|»PÂØz 
¥H¤U¬O¤ß±oµù¸Ñ,½Ð«e½ú°Ñ¦Ò,¤]½Ð¦U¦ì«e½ú«ü¾É,ÁÂÁ 
 
Option Explicit 
Sub TEST_20221220() 
Application.DisplayAlerts = False 
'¡ô°õ¦æ¹Lµ{¤£n¸õ¥X(°Ý¤u§@ªí¬O¤£¬O½T©wn§R°£?)µøµ¡ 
'https://learn.microsoft.com/zh-tw/office/vba/api/excel.application.displayalerts 
Application.ScreenUpdating = False 
'¡ô¿Ã¹õ¤£ÀHµÛµ{¦¡°õ¦æÅܤƵ²ªG 
Dim i&, T3&, m&, N&, T1$, T6$, Arr, W, X, Y, Z, C, R, S 
'¡ô«Å§iÅܼÆ:(i,T3,m,N)¬Oªø¾ã¼ÆÅܼÆ,(T1,T6)¬O¦r¦êÅܼÆ,¨ä¥Lªº¬O³q¥Î«¬ÅÜ¼Æ 
Set X = CreateObject("Scripting.Dictionary") 
Set Y = CreateObject("Scripting.Dictionary") 
Set W = CreateObject("Scripting.Dictionary") 
'¡ô¥OX,Y,Z ¦U¬O ¦r¨å 
Arr = Range([eb!F2], [eb!A1].Cells(Rows.Count, 1).End(xlUp)) 
'¡ô¥OArr¬O¤Gºû°}¦C!ˤJ±qebªí[F2]¨ìebªíAÄæ³Ì«á¤@Ó¦³¤º®eÀx¦s®æ, 
'ÂX®i¥X³Ì¤p¤è¥¿°Ï°ìÀx¦s®æªºÈ 
For i = 1 To UBound(Arr) 
'¡ô³]¶¶°j°é!i±q1¨ìArr°}¦CÁa¦V³Ì¤j¯Á¤Þ¦C¸¹ 
   If W(Arr(i, 1)) = Empty Then 
   '¡ô¦pªG¥Hi°j°é¦C²Ä1ÄæªºArr°}¦CȬdW¦r¨å¬O¨S¦³³okey?? 
      S = S + 1 
      '¡ôif±ø¥ó¦¨¥ß!´NÅýS²Ö¥[1 
      W(Arr(i, 1)) = S 
      '¡ô¥Oi°j°é¦C²Ä1ÄæªºArr°}¦CÈ·íkey,Item¬O SÅÜ¼Æ 
      Arr(i, 2) = S 
      '¡ô¥Oi°j°é¦C²Ä2ÄæªºArr°}¦CȤ]¬O SÅÜ¼Æ 
      Else 
      '¡ô¥H¤U¬Oif±ø¥ó¤£¦¨¥ß¤~°õ¦æªº 
         Arr(i, 2) = W(Arr(i, 1)) 
         '¡ô¥Oi°j°é¦C²Ä2ÄæªºArr°}¦CȬO ¥Hi°j°é¦C²Ä1ÄæªºArr°}¦CȬdW¦r¨å±o¨ìªºitemÈ 
   End If 
Next 
With Sheets.Add 
'¡ô¥H¤U¬OÃö©ó·s¼W¤@Ó¤u§@ªíªºµ{§Ç 
   With .[A1].Resize(UBound(Arr), UBound(Arr, 2)) 
   '¡ô¥H¤U¬OÃö©ó·s¼W¤u§@ªí¸Ì[A1]¦V¤UÂX®i Arr°}¦CÁa¦V³Ì¤j¯Á¤Þ¦C¸¹¼Æ, 
   '¦V¥kÂX®i Arr°}¦C¾î¦V¦V³Ì¤j¯Á¤ÞÄæ¸¹¼Æ,³o¤è¥¿½d³òÀx¦s®æªºµ{§Ç 
      .Value = Arr 
      '¡ô¥O³o½d³òÀx¦s®æÈ ¥HArr°}¦CÈˤJ 
      .Sort _ 
      KEY1:=.Item(2), Order1:=xlAscending, _ 
      Key2:=.Item(6), Order2:=xlAscending, _ 
      Header:=xlNo, Orientation:=xlTopToBottom 
      '¡ô¥O¥H²Ä2Äæ°µ²Ä¤@¼h°µ¨S¦³¼Ð¦Cªº¤W¤U¶¶±Æ§Ç,²Ä6Äæ¦P®É°µ²Ä¤G¼h¤W¤U¶¶±Æ§Ç 
      Arr = .Value 
      '¡ô¥OArr°}¦C˱¼ì¨ÓªºÈ,¸Ë¤J³o±Æ§Ç¦nªºÀx¦s®æÈ 
   End With 
   .Delete 
   '¡ô¥O³o·s¼W¤u§@ªí§R°£ 
End With 
For i = 1 To UBound(Arr) 
'¡ô³]¶¶°j°é!i±q1¨ì Arr°}¦CÁa¦V³Ì¤j¯Á¤Þ¦C¸¹¼Æ 
   T1 = Arr(i, 1) 
   '¡ô¥OT1³o¦r¦êÅܼƬO i°j°é¦C²Ä1ÄæªºArr°}¦CÈ 
   T3 = Arr(i, 3) 
   '¡ô¥OT3³oªø¾ã¼ÆÅܼƬO i°j°é¦C²Ä3ÄæªºArr°}¦CÈ 
   T6 = Arr(i, 6) 
   '¡ô¥OT6³o¦r¦êÅܼƬO i°j°é¦C²Ä6ÄæªºArr°}¦CÈ 
   If X(T1 & "|" & T6) = Empty Then 
   '¡ô¦pªG¥H T1¦r¦êÅܼƳs±µ "|" ²Å¸¹,¦A³s±µT6¦r¦êÅÜ¼Æ ªº·s¦r¦ê¬dW¦r¨å! ¬O¨S¦³³okey?? 
      Y(T1) = Y(T1) + 1 
      '¡ô¥O¥H T1¦r¦êÅܼƷíkey,Item¬O¦Û¤v +1 ©ñ¨ì¦r¨å¸Ì©Î´£¥X¨Ó+1¦A©ñ¦^¥h 
      X(T1 & "|" & T6) = Y(T1) 
      '¡ô¥O¥H T1¦r¦êÅܼƳs±µ "|" ²Å¸¹,¦A³s±µT6¦r¦êÅÜ¼Æ ªº·s¦r¦ê·íkey,item¬O Y(T1) ©ñ¨ì¦r¨å¸Ì 
      If Y(T1) > m Then m = Y(T1) 
      '¡ô¦pªG¥H T1¦r¦êÅܼƬdY¦r¨åªºitemȬO ¤j©ó m³oªø¾ã¼ÆÅܼÆ, 
      '´NÅým±a¤J T1¦r¦êÅܼƬdY¦r¨åªºitemÈ 
   End If 
   W(T1 & "|" & T6) = W(T1 & "|" & T6) + T3 
   '¡ô¥OT1¦r¦êÅܼƳs±µ "|" ²Å¸¹,¦A³s±µT6¦r¦êÅÜ¼Æ ªº·s¦r¦ê·íkey, 
   'Item¬O¦Û¤v + T3³oªø¾ã¼ÆÅÜ¼Æ ©ñ¨ì¦r¨å¸Ì©Î´£¥X¨Ó+1¦A©ñ¦^¥h 
Next 
ReDim Arr(1 To Y.Count, 1 To m + 3) 
'¡ô«Å§iArr°}¦Cªº½d³ò!Áa¦V±q1¨ìY¦r¨å¸Ìkeyªº¼Æ¶q,¾î¦V±q1¨ì mªø¾ã¼ÆÅܼÆ+3 
For Each R In Y.KEYS 
'¡ô³]¶¶°j°é!¥OR³o³q¥Î«¬ÅܼƬO Y¦r¨å¸Ìªºkey,±q«e±½ü¨ì³Ì«á± 
   N = N + 1 
   '¡ô¥ON³oªø¾ã¼ÆÅܼƲ֥[ 1 
   Arr(N, 1) = "'" & R 
   '¡ô¥ONªø¾ã¼ÆÅܼƦC²Ä1ÄæArr°}¦CȬO "'"²Å¸¹³s±µR°j°ékeyÈ 
   Y(R) = N 
   '¡ô¥OR°j°ékeyÈ·íY°}¦Cªºkey,item¬ONªø¾ã¼ÆÅÜ¼Æ 
Next 
For Each C In X.KEYS 
'¡ô³]¶¶°j°é!¥OC³o³q¥Î«¬ÅܼƬO X¦r¨å¸Ìªºkey,±q«e±½ü¨ì³Ì«á± 
   Arr(Y(Split(C, "|")(0)), X(C) + 3) = Split(C, "|")(1) & "/" & W(C) 
   '¡ô¥OArr°}¦C (C°j°ékeyÈ¥H"|"²Å¸¹¤À³Î¦¨¤@ºû°}¦C«á ¨ú¯Á¤Þ¸¹0ªº°}¦CÈ ·íkey¬dY¦r¨å±oitemÈ)¦C, 
   '(C°j°ékeyÈ ·íkey¬dY¦r¨å±oitemÈ+3)Äæ ªºÈ¬O, 
   'C°j°ékeyÈ¥H"|"²Å¸¹¤À³Î¦¨¤@ºû°}¦C«á¨ú¯Á¤Þ¸¹1ªº°}¦Cȳs±µ "/"²Å¸¹, 
   '¦A³s±µ ¥HC°j°ékeyȬdW¦r¨åªºitemÈ 
Next 
Sheets("List").UsedRange.Offset(1, 0).Clear 
'¡ô¥O"List"¤u§@ªí¦³¨Ï¥ÎªºÀx¦s®æÂX®i³Ì¤p¤è¥¿°Ï°ì¦A©¹¤U°¾²¾¤@¦Cªº°Ï°ìÀx¦s®æ ²M°£ 
[List!A2].Resize(UBound(Arr), UBound(Arr, 2)) = Arr 
'¡ô¥O"List"¤u§@ªí[A2]©¹¤UÂX®i Arr°}¦CÁa¦V³Ì¤j¯Á¤Þ¦C¸¹¼Æ, 
'©¹¥kÂX®iArr°}¦C¾î¦V³Ì¤j¯Á¤ÞÄæ¸¹¼Æ³o¤è¥¿°Ï°ìªºÀx¦s®æÈ¬O Arr°}¦CÈ 
Set X = Nothing 
Set Y = Nothing 
Set Z = Nothing 
Set Arr = Nothing 
'¡ô¥O³o¨ÇÅܼÆÄÀ©ñ 
End Sub |   
 
 
 
 |