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

¦^´_ 1# sschristy

ÁÂÁ«e½úµoªí¦¹¥DÃD
«á¾Ç¾Ç²ßªº«Øij¤è®×½d¨Ò¦p¤U:

1.¶}¤@­Ó·s¬¡­¶Ã¯
2.§â¤U¦Cµ{¦¡½X´Ó¤JVBA¼Ò²Õ¤¤°µ´ú¸Õ
2.1.¥ý°õ¦æ¶Ã¼Æ­«³]>>²£¥Í¸ê®Æ
2.2.¦A°õ¦æ¨âºØ¦X­p

Option Explicit
Sub EÄæ¦P©³¦â¦X­p_1()
Application.EnableEvents = False
Dim i&, C3&, C17&, T, C&
T = Timer
For i = 1 To Cells(Rows.Count, "E").End(3).Row
   C = Cells(i, "E").Interior.ColorIndex
   If C = 3 Then C3 = C3 + Val(Cells(i, "E"))
   If C = 17 Then C17 = C17 + Val(Cells(i, "E"))
Next
[B1] = C3: [A1].Interior.ColorIndex = 3
[B2] = C17: [A2].Interior.ColorIndex = 17
Application.EnableEvents = True
MsgBox Format(Timer - T, "0.00’")
End Sub

Sub EÄæ¦P©³¦â¦X­p_2()
Application.EnableEvents = False
Dim i&, C&, Y, Arr, T
T = Timer
Set Y = CreateObject("Scripting.Dictionary")
Arr = Range([E1], Cells(Rows.Count, "E").End(3))
For i = 1 To UBound(Arr)
   C = Cells(i, "E").Interior.ColorIndex
   Y(C) = Y(C) + Val(Arr(i, 1))
Next
[B1] = Y(3): [A1].Interior.ColorIndex = 3
[B2] = Y(17): [A2].Interior.ColorIndex = 17
Application.EnableEvents = True
MsgBox Format(Timer - T, "0.00’")
End Sub

Sub ¶Ã¼Æ­«³]()
Dim xArea, xR, R
Set xArea = [E1:E10000]
With xArea
   .Value = "=INT(RAND()*100)"
   .Value = .Value
   .Interior.ColorIndex = 17
End With
For Each xR In xArea
   If Int(Rnd() * 100) Mod 2 Then xR.Interior.ColorIndex = 3
Next
[B1:B2] = ""
End Sub

¶Ã¼Æ­«³]:

¤U¸ü (74.17 KB)

2023-2-17 15:06

¦X­pµ²ªG:

¤U¸ü (89.65 KB)

2023-2-17 15:06

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

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

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

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

¦^´_ 6# Andy2483


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

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

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

sschristy

¦^´_ 9# Andy2483


    ·PÁ«ü¾É