EXCEL ActiveX±±¨î«ö¶s ½Ð±Ð
| ©«¤l1480 ¥DÃD40 ºëµØ0 ¿n¤À1504 ÂI¦W0  §@·~¨t²ÎWindows  7 ³nÅ骩¥»Excel 2010 & 2016 ¾\ŪÅv100 ©Ê§O¨k ¨Ó¦Û¥xÆW µù¥U®É¶¡2020-7-15 ³Ì«áµn¿ý2025-10-27 
 | 
                
| ¥»©«³Ì«á¥Ñ Andy2483 ©ó 2023-2-20 15:37 ½s¿è 
 ¦^´_ 10# sschristy
 
 
 ÁÂÁ«e½ú¦^´_
 ¥H¤U¦A×¥¿½Æ²ß¤ß±oµù¸Ñ,¥[²`¾Ç²ß¦L¶H,½Ð«e½ú°Ñ¦Ò
 
 Option Explicit
 Sub «ºâ2()
 Dim xR As Range, xU, Y, Arr(1 To 8, 1 To 4), N&, R&, C%
 '¡ô«Å§iÅܼÆ:xR¬OÀx¦s®æÅܼÆ,(xU,Y)¬O³q¥Î«¬ÅܼÆ,
 'Arr¬O¤Gºû°}¦C!Áa¦V±q1¨ì8¯Á¤Þ¦C¸¹,¾î¦V±q1¨ì4¯Á¤ÞÄæ¸¹,(N,R)¬Oªø¾ã¼Æ,C¬Oµu¾ã¼Æ
 Set Y = CreateObject("Scripting.Dictionary")
 '¡ô¥OY¬O ¦r¨å
 For Each xU In Split("6/47/44/48/46/23/NA/50", "/")
 '¡ô³]°j°é!¥OxU¬O Split()¤@ºû°}¦Cªº¤@°}¦C¤l
 N = N + 1: Y(xU) = N
 '¡ô¥ON²Ö¥[1:¥O¥H xUÅܼƬ°key,item¬°NÅÜ¼Æ ¯Ç¤JY¦r¨å
 Next
 For Each xU In Array(Range("A°Ï"), Range("B°Ï"), Range("C°Ï"), Range("D°Ï"))
 '¡ô³]°j°é!¥OxU¬O Array()°}¦Cªº¤@°}¦C¤l
 C = C + 1
 '¡ô¥OC²Ö¥[1
 For Each xR In xU
 '¡ô³]°j°é!¥OxR¬O xUÅܼƤ¤ªº¤@¤¸¯À
 R = xR.Interior.ColorIndex
 '¡ô¥OR¬OxRÅܼƪº©³¦â¥N¸¹
 If Y.Exists(R & "") = Empty Then GoTo 111
 '¡ô¦pªGRÅܼƳs±µªÅ¦r¤¸¬°key,Y¦r¨åExists()¦^¶Çªº¬Oªì©lÈ(µL¦¹ÃC¦â¥N¸¹),
 '¸õ¨ì111¦ì¸mÄ~Äò°õ¦æ
 Arr(Y(R & ""), C) = Arr(Y(R & ""), C) + xR.Value
 '¡ô¥O¦r¨å¦^¶ÇȦC²ÄCÅܼÆÄæArr°}¦CȬO ¦Û¨+xRÅܼƪºÈ
 'PS ¦r¨å¦^¶ÇÈ:(R³s±µªÅ¦r¤¸)¬dY¦r¨å,¦^¶ÇªºitemÈ
 111
 Next
 Next
 With Sheets("²Îpªí")
 '¡ô¥H¤U¬OÃö©ó "²Îpªí"¤u§@ªíªºµ{§Ç
 .[A1:F10].Copy .[A11]
 '¡ô¥Oªí[A1:F10]Àx¦s®æ ½Æ»s¨ì ªí[A11]
 .[B13].Resize(8, 4) = Arr
 '¡ô¥Oªí[B13]ÂX®i¦V¤U8¦C,ÂX®i¦V¥k4Äæ½d³òÀx¦s®æÈ¥HArr°}¦Cȱa¤J
 Application.Goto .[A1]
 '¡ô¥OÀx¦s®æ´å¼Ð ¸õ¨ì ªí[A1]
 End With
 Set Y = Nothing
 Erase Arr
 End Sub
 | 
 | 
| ¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y
 | 
|  |  | 
|  |  |