Option Explicit
Sub E欄同底色合計_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欄同底色合計_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
1.在顏色分類 工作表模組植入以下程式碼:
Private Sub Worksheet_Activate()
[統計表!G1] = 0
End Sub
2.在統計表 工作表模組植入以下程式碼:
Private Sub Worksheet_Activate()
[統計表!G1] = 1
End Sub
3.將下列藍字添加
Function GetRangeColor(xA As Range, xArea As Range, xType%)
Dim xR As Range, X, S(5), C&
'Application.Volatile
If [統計表!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) '合計
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) '最大值
If S(5) = Empty Or S(0) < S(5) Then S(5) = S(0) '最小值
End If
Next
GetRangeColor = S(xType)
End Function
Sub 重算()
[統計表!G1:H1] = 0
[統計表!G1] = 1
[統計表!H1] = 1
End Sub
Function GetRangeColor(xA As Range, xArea As Range, xType%)
Dim xR As Range, X, S(5), C&
'Application.Volatile
If [統計表!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) '合計
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) '最大值
If S(5) = Empty Or S(0) < S(5) Then S(5) = S(0) '最小值
End If
Next
GetRangeColor = S(xType)
End Function作者: Andy2483 時間: 2023-2-20 10:19
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("統計表")
.[A1:F10].Copy .[A11]
.[B13].Resize(8, 4) = Arr
Application.Goto .[A1]
End With
Set Y = Nothing
Erase Arr
End Sub
Option Explicit
Sub 重算2()
Dim xR As Range, xU, Y, Arr(1 To 8, 1 To 4), N&, R&, C%
'↑宣告變數:xR是儲存格變數,(xU,Y)是通用型變數,
'Arr是二維陣列!縱向從1到8索引列號,橫向從1到4索引欄號,(N,R)是長整數,C是短整數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y是 字典
For Each xU In Split("6/47/44/48/46/23/NA/50", "/")
'↑設迴圈!令xU是 Split()一維陣列的一陣列子
N = N + 1: Y(xU) = N
'↑令N累加1:令以 xU變數為key,item為N變數 納入Y字典
Next
For Each xU In Array(Range("A區"), Range("B區"), Range("C區"), Range("D區"))
'↑設迴圈!令xU是 Array()陣列的一陣列子
C = C + 1
'↑令C累加1
For Each xR In xU
'↑設迴圈!令xR是 xU變數中的一元素
R = xR.Interior.ColorIndex
'↑令R是xR變數的底色代號
If Y.Exists(R & "") = Empty Then GoTo 111
'↑如果R變數連接空字元為key,Y字典Exists()回傳的是初始值(無此顏色代號),
'跳到111位置繼續執行
Arr(Y(R & ""), C) = Arr(Y(R & ""), C) + xR.Value
'↑令字典回傳值列第C變數欄Arr陣列值是 自身+xR變數的值
'PS 字典回傳值:(R連接空字元)查Y字典,回傳的item值
111
Next
Next
With Sheets("統計表")
'↑以下是關於 "統計表"工作表的程序
.[A1:F10].Copy .[A11]
'↑令表[A1:F10]儲存格 複製到 表[A11]
.[B13].Resize(8, 4) = Arr
'↑令表[B13]擴展向下8列,擴展向右4欄範圍儲存格值以Arr陣列值帶入
Application.Goto .[A1]
'↑令儲存格游標 跳到 表[A1]
End With
Set Y = Nothing
Erase Arr
End Sub
