EXCEL ActiveX±±¨î«ö¶s ½Ð±Ð

sschristy

½Ð°Ý¦U¦ì°ª¤â¡A§ÚEXCEL¤º¦³¤@­ÓVBA¥\¯à¬O¥i¥H¨Ì·ÓÀx¦s®æÃC¦â¦Û°Ê­pºâÁ`©M¡A¦ý¬O¥u­n§ó°Ê¤F¤@­Ó¼Æ­È¡A´N·|¦Û°Ê§ó·s¡A³o¼Ë·í§Ú¸ê®Æ¶V¨Ó¶V¦h¾ã­Ó¹q¸£³t«×´N·|³Q©ìºC¡A¬O§_¥i¥H±N¦¹¥\¯à¼g¤JActiveX±±¨î«ö¶s¤¤¡A·í§Ú¦³»Ý­n®É¦A¥þ³¡§ó·s©O¡H

¤U¸ü (29.1 KB)

2023-2-17 11:34

Andy2483

¦^´_ 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

sschristy

¦^´_ 9# Andy2483


    ·PÁ«ü¾É

Andy2483

¦^´_ 7# sschristy


    ÁÂÁ«e½ú
«á¾Ç¾Ç²ß°}¦C»P¦r¨åªº¥t¤@¤è®×,½Ð«e½ú¸Õ¸Õ¬Ý,ÁÂÁÂ

Option Explicit
Sub ­«ºâ2()
Dim xR As Range, xU, Y, Arr(1 To 8, 1 To 4), N&, C#, R&
Set Y = CreateObject("Scripting.Dictionary")
For Each xU In Split("6/47/44/48/46/23/NA/50", "/")
   N = N + 1: Y(xU) = N
Next
For Each xU In Array(Range("A°Ï"), Range("B°Ï"), Range("C°Ï"), Range("D°Ï"))
   C = C + 1
   For Each xR In xU
      R = xR.Interior.ColorIndex
      If Y.Exists(R & "") = Empty Then GoTo 111
      Arr(Y(R & ""), C) = Arr(Y(R & ""), C) + xR.Value
111
   Next
Next
With Sheets("²Î­pªí")
   .[A1:F10].Copy .[A11]
   .[B13].Resize(8, 4) = Arr
   Application.Goto .[A1]
End With
Set Y = Nothing
Erase Arr
End Sub

¤U¸ü (54.67 KB)

2023-2-20 10:22

Andy2483

¦^´_ 7# sschristy


    ÁÂÁ«e½ú¦A¦^´_
«ö¶s¤è¦¡:

¤U¸ü (36.67 KB)

2023-2-18 15:02

Sub ­«ºâ()
[²Î­pªí!G1:H1] = 0
[²Î­pªí!G1] = 1
[²Î­pªí!H1] = 1
End Sub

Function GetRangeColor(xA As Range, xArea As Range, xType%)
Dim xR As Range, X, S(5), C&
'Application.Volatile
If [²Î­pªí!H1] = 1 Then Exit Function
X = xA.Interior.ColorIndex
For Each xR In xArea
    If xR.Interior.ColorIndex = X Then
       S(0) = Val(xR.Value)
       S(1) = S(1) + S(0) '¦X­p
       S(2) = S(2) + 1 '­Ó¼Æ
       If S(2) > 0 Then S(3) = S(1) / S(2) '¥­§¡­È
       If S(0) > S(4) Then S(4) = S(0) '³Ì¤j­È
       If S(5) = Empty Or S(0) < S(5) Then S(5) = S(0) '³Ì¤p­È
    End If
Next
GetRangeColor = S(xType)
End Function

sschristy

¦^´_ 6# Andy2483


    ·PÁ´£¨Ñ¥t¥~ªº·Qªk¡A¦ýÁÙ¬O·Qª¾¹D¬O§_¥i¥H¥Î«ö¶s¨Ó°õ¦æ¡H

Andy2483

¦^´_ 5# sschristy


    ÁÂÁ«e½ú¦^´_´£¨Ñ½d¨Ò
«á¾Ç«Øij¤è®×¬O¥H¤u§@ªí¤Á´«¤~­«ºâ,¤£¥²¼W³]«ö¶s:

1.¦bÃC¦â¤ÀÃþ ¤u§@ªí¼Ò²Õ´Ó¤J¥H¤Uµ{¦¡½X:
Private Sub Worksheet_Activate()
[²Î­pªí!G1] = 0
End Sub

2.¦b²Î­pªí ¤u§@ªí¼Ò²Õ´Ó¤J¥H¤Uµ{¦¡½X:
Private Sub Worksheet_Activate()
[²Î­pªí!G1] = 1
End Sub

3.±N¤U¦CÂŦr²K¥[
Function GetRangeColor(xA As Range, xArea As Range, xType%)
Dim xR As Range, X, S(5), C&
'Application.Volatile
If [²Î­pªí!G1] = 0 Then Exit Function
X = xA.Interior.ColorIndex
For Each xR In xArea
    If xR.Interior.ColorIndex = X Then
       S(0) = Val(xR.Value)
       S(1) = S(1) + S(0) '¦X­p
       S(2) = S(2) + 1 '­Ó¼Æ
       If S(2) > 0 Then S(3) = S(1) / S(2) '¥­§¡­È
       If S(0) > S(4) Then S(4) = S(0) '³Ì¤j­È
       If S(5) = Empty Or S(0) < S(5) Then S(5) = S(0) '³Ì¤p­È
    End If
Next
GetRangeColor = S(xType)
End Function

4.¨â­Ó¤u§@ªí¤Á´«¬Ý¬Ý,ÃC¦â¤ÀÃþ ¤u§@ªí¿é¤J·s¼Æ¦r´ú¸Õ¬Ý¬Ý

¤U¸ü (29.67 KB)

2023-2-18 13:26

¤U¸ü (32.28 KB)

2023-2-18 13:26

sschristy

¦^´_ 4# Andy2483

·PÁ¦^ÂСA¤W¶Çªþ¥ó¨Ñ°Ñ¦Ò¡A¦]¬°¸ê®Æ¼Æ¶qÃe¤j¡A¦pªG¨C§ó§ï¤@¦¸´N¹Bºâ¤@¦¸¦Û­q¨ç¼Æ¡A¹q¸£·|ÅܫܺC¡A©Ò¥H·Q­n°µ¤@­Ó«ö¶s¡A«ö¤F¤§«á¦A¤@°_­pºâ






¨ÌÃC¦â²Î­p¼Æ¶q.zip (137.74 KB)

¤U¸ü¦¸¼Æ: 3

2023-2-18 12:45

Andy2483

¦^´_ 3# sschristy


    ÁÂÁ«e½ú¦^´_
http://forum.twbts.com/thread-23804-1-2.html
¤µ¤Ñ¦A¬ã¨s¹L³o©«,¸g´ú¸Õ¤ß±o«Øij«e½ú¦p¤U¤èªk°µ´ú¸Õ,©Î³\´N¥i¥H´î¤Ö­«ºâ¦¸¼Æ
1.'Application.Volatile,¦b³o¦æ«e­±¥[³æ¤Þ¸¹,Åܦ¨µù¸Ñ,·|Åܦ¨¥u¦³²Î­p¸ê®Æ½d³òªºÀx¦s®æ³Q½s¿è¦¨¤£¦P¼Æ­È¤~·|­«ºâ
2.Application.Volatile ¤èªkªºª¾ÃѬd¸ßºô­¶:
https://learn.microsoft.com/zh-t ... pplication.volatile
3.¦ý¬O¦¹¤èªk¦³¤@­Ó¯ÊÂI:¦pªG²Î­p¸ê®Æ½d³òªºÀx¦s®æ¥u¦³³QÅÜÀx¦s®æ©³¦â! ¸ê®Æ¤£·|³Q­«ºâ,
¥u¦³²Î­p¸ê®Æ½d³òªºÀx¦s®æ³Q½s¿è¦¨¤£¦P¼Æ­È¤~·|­«ºâ

¥H¤W³£¥u¬O±¡¹Ò²q´ú,¦pªG¥i¥H¤W¶Ç½d¨Ò¨Ñ¬ã¨s¥i¥H§ó©ú½T

sschristy

¦^´_ 2# Andy2483


    ·PÁ¦^´_¡A¦ý¸ò§Ú·Q­nªº®ÄªG¦ü¥G¤£¤Ó¤@¼Ë¡A§Ú¬O¦bEXCEL¤@¯ë°Ï¤º"¦³ÃC¦âÀx¦s®æ¼Æ¦r¥[Á`"¡A¬Ý¨ì­ã´£³¡ªL¤j¤j©Ò±ÐªºVBA¦Û­q¨ç¼Æ¡A¥¿¦n¥i¥H¥Î¦b¤u§@¤W¡A
¦ý¬O§Ú¹ê»Úªº¸ê®Æ¶q«Ü¤j¡A¨C§ï¤@¦¸¼Æ¦r¡A¨ç¼Æ´N·|¦Û°Ê­pºâ¡A¦]¦¹·Q­n¸ß°Ý¬O§_¥i¥HÅý¦¹¨ç¼Æ¥u¦b§Ú·Q­nªº®É­Ô¦A¹Bºâ¡C¨Ò¦p¥[¤W¤@­Ó±±¨î«ö¶s¡A«ö¤U«á´N·|§ó·s¡C