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

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

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

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

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