| ©«¤l1478 ¥DÃD40 ºëµØ0 ¿n¤À1502 ÂI¦W0  §@·~¨t²ÎWindows  7 ³nÅ骩¥»Excel 2010 & 2016 ¾\ŪÅv100 ©Ê§O¨k ¨Ó¦Û¥xÆW µù¥U®É¶¡2020-7-15 ³Ì«áµn¿ý2025-10-23 
 | 
                
| ¦^´_ 1# v03586 
 
 ÁÂÁ«e½úµoªí¦¹¥DÃD»P½d¨Ò,ÁÂÁ¦U¦ì«e½ú,ÁÂÁ½׾Â
 «á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ßªº¸Ñ¨M¤è®×¦p¤U,½Ð«e½ú°Ñ¦Ò
 ½Ð¦U¦ì«e½ú«ü±Ð
 
 °õ¦æ«e:
 
     
 °õ¦æµ²ªG:
 
     
 
 Option Explicit
 Sub TEST_2()
 Dim Brr, Y, T$, C%, j%, i&, xA As Range
 '¡ô«Å§iÅܼÆ:(Brr,Y)¬O³q¥Î«¬ÅܼÆ,T¬O¦r¦êÅܼÆ,
 '(C,j)¬Oµu¾ã¼Æ,i¬Oªø¾ã¼Æ,xA¬OÀx¦s®æÅܼÆ
 Set Y = CreateObject("Scripting.Dictionary")
 '¡ô¥OY³o³q¥Î«¬ÅܼƬO ¦r¨å
 Set xA = Range([M1], Cells(Rows.Count, 1).End(3)): Brr = xA
 '¡ô¥OxA³oÀx¦s®æÅܼƬO [M1]ÂX®i¨ìAÄæ³Ì«á¦³¤º®eÀx¦s®æ
 '¥OBrr³o³q¥Î«¬ÅܼƬO ¤Gºû°}¦C,¥HxAÅܼÆ(Àx¦s®æÈ)±a¤J
 C = UBound(Brr, 2)
 '¡ô¥OC³oµu¾ã¼ÆÅܼƬO Brr°}¦C¾î¦V³Ì¤j¯Á¤ÞÄæ¸¹
 For i = 2 To UBound(Brr)
 '¡ô³]¶¶°j°é!i±q2¨ì Brr°}¦CÁa¦V³Ì¤j¯Á¤Þ¦C¸¹
 T = Brr(i, 9) & "|" & Brr(i, 10)
 '¡ô¥OT³o¦r¦êÅܼƬO i°j°é¦C²Ä9ÄæBrr°}¦CÈ ³s±µ "|",
 '¦A³s±µ i°j°é¦C²Ä10ÄæBrr°}¦CÈ,©Ò²Õ¦¨ªº·s¦r¦ê
 If Y(T) = "" Then
 '¡ô¦pªGTÅܼƬdY¦r¨åªºitemȬOªÅ¦r¤¸?
 '(³o°Ý¥y¤w¸g±N TÅܼƷíkey,item¬OªÅ¦r¤¸,¯Ç¤JY¦r¨å¤F,¤w¼W¥[Ó·skey)
 Y(T) = Y.Count + 1
 '¡ô¥O TÅܼƷíkey,item¬O Y¦r¨åkey¼Æ¶q + 1
 For j = 1 To C - 1: Brr(Y(T), j) = Brr(i, j): Next
 '¡ô³]¶¶°j°é!j±q1¨ì CÅܼÆ-1,³°Äò±N¸Ó¦C¦UÄæÈ±a¤J«ü©w¦C¦PÄæ¦ì¸m
 Brr(Y(T), 13) = Brr(Y(T), 12): GoTo i01
 '¡ô¥O(TÅܼƬdY¦r¨åitemÈ)¦C²Ä13ÄæBrr°}¦CȬO
 '(TÅܼƬdY¦r¨åitemÈ)¦C²Ä12ÄæBrr°}¦CÈ
 '¥Oµ{§Ç¸õ¨ì i01¼Ð¥Ü¦ì¸mÄ~Äò°õ¦æ
 End If
 Brr(Y(T), 13) = Brr(Y(T), 13) + Brr(i, 12)
 '¡ô¥O(TÅܼƬdY¦r¨åitemÈ)¦C²Ä13ÄæBrr°}¦CȬO
 '¦Û¨È + (TÅܼƬdY¦r¨åitemÈ)¦C²Ä12ÄæBrr°}¦CÈ
 i01: Next
 ActiveSheet.UsedRange.Clear
 '¡ô¥O¦³¨Ï¥ÎÀx¦s®æ½d³ò°µ²M°£
 xA.Resize(Y.Count + 1, C) = Brr
 '¡ô¥OxAÅܼÆ(Àx¦s®æ)²Ä1®æÂX®i¦V¤U Y¦r¨åkey¼Æ¶q+1¦C,
 '¦V¥kÂX®iCÅܼÆÄæ,³o½d³òÀx¦s®æÈ¥HBrr°}¦Cȱa¤J
 Set Y = Nothing: Set xA = Nothing: Erase Brr
 'ÄÀ©ñÅܼÆ
 End Sub
 | 
 |