EXCEL ActiveX±±¨î«ö¶s ½Ð±Ð
- ©«¤l
- 1446
- ¥DÃD
- 40
- ºëµØ
- 0
- ¿n¤À
- 1470
- ÂI¦W
- 0
- §@·~¨t²Î
- Windows 7
- ³nÅ骩¥»
- Excel 2010 & 2016
- ¾\ŪÅv
- 50
- ©Ê§O
- ¨k
- ¨Ó¦Û
- ¥xÆW
- µù¥U®É¶¡
- 2020-7-15
- ³Ì«áµn¿ý
- 2024-10-21
|
¥»©«³Ì«á¥Ñ 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
|
|
|
|
|