程式碼如下:
Option Explicit
Sub 字典與陣列練習()
Dim Arr, Brr(1), Crr, C, i, Sh, xR As Range, Y, U, R, Tc, TT, N, Q, T
T = Timer
Set Y = CreateObject("Scripting.Dictionary")
Set Sh = Sheets("操作表")
R = Sh.UsedRange.EntireRow.Rows.Count
C = Sh.UsedRange.EntireColumn.Columns.Count
Set Arr = Range(Sh.[A1], Sh.Cells(R, C))
For Each xR In Arr
If IsNumeric(xR.Value) = False Or xR.Value = "" Then GoTo 888
Tc = xR.Interior.Color
TT = xR.Interior.TintAndShade
Crr = Y(Tc & "|" & TT)
If Not IsArray(Crr) Then
Crr = Brr
End If
Crr(0) = Crr(0) + xR.Value
If Crr(1) = "" Then
Crr(1) = xR.Value
Else
Crr(1) = Crr(1) & "," & xR.Value
End If
Y(Tc & "|" & TT) = Crr
888
Next
Workbooks.Add
[A1] = "顏色→": [A2] = "數字加總→": [A3] = "↓以下是明細"
[B2].Resize(2, Y.Count) = Application.Transpose(Y.ITEMS)
N = 1
For Each i In Y.KEYS
N = N + 1
Cells(1, N).Interior.Color = Val(Split(i, "|")(0))
Cells(1, N).Interior.TintAndShade = Val(Split(i, "|")(1))
Q = Split(Cells(3, N), ",")
Cells(3, N).Resize(UBound(Q) - LBound(Q) + 1, 1) = Application.Transpose(Q)
Next
[A2].CurrentRegion.Value = [A2].CurrentRegion.Value
Cells.Columns.AutoFit
Cells.Borders.LineStyle = 1
MsgBox Timer - T & " 秒"
End Sub作者: Andy2483 時間: 2022-11-3 13:19
簡單將練習心得註解一下:
Option Explicit
Sub 字典與陣列練習()
Dim Arr, Brr(1 To 100000, 1 To 1), Crr, C, i, Sh, xR As Range
Dim N&, T, Y, U, R, Tc, Ti, Q, TT
'↑宣告變數
T = Timer
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y是字典
Set Sh = Sheets("操作表")
'↑令Sh 是 操作表
R = Sh.UsedRange.EntireRow.Rows.Count
'↑令R 是有使用的列數
C = Sh.UsedRange.EntireColumn.Columns.Count
'↑令C 是有使用的欄數
Set Arr = Range(Sh.[A1], Sh.Cells(R, C))
'↑令Arr是陣列!倒入有使用的儲存格值
For Each xR In Arr
'↑設順迴圈!令xR 是Arr陣列的一員
If IsNumeric(xR.Value) = False Or xR.Value = "" Then GoTo 888
'↑如果 陣列值不是數字 或 陣列值是空字元! 就跳到 888位置繼續執行
Tc = xR.Interior.Color
'↑令Tc 是顏色
Ti = xR.Interior.TintAndShade
'↑令Ti 是深淺
TT = Tc & "|" & Ti
'↑令TT 是顏色 & "|" & 深淺 組合字串
Crr = Y(TT)
'↑令Crr陣列是 組合字串為key的 Y字典item
If Not IsArray(Crr) Then
'↑如果Crr 不是陣列
N = N + 1
'↑顏色種類累加 1
Y(TT & "/z") = N
'↑令 組合字串& "/z" 為key,顏色種類數為item 倒入Y字典
Crr = Brr
'↑令Crr 是Brr空陣列
End If
Y(TT & "/r") = Y(TT & "/r") + 1
'↑令 組合字串& "/r" 為key倒入Y字典,item累加 1
Y(TT & "/a") = Y(TT & "/a") + xR.Value
'↑令 組合字串& "/a" 為key倒入Y字典,item累加 xR的值
Crr(Y(TT & "/r"), 1) = xR.Value
'↑將 xR的值倒入指定的 Crr陣列位置
Y(TT) = Crr
'↑將Crr倒入Y字典中
888
Next
Workbooks.Add
[A1] = "顏色→": [A2] = "數字加總→": [A3] = "↓以下是明細"
For Each TT In Y.KEYS
'↑設順迴圈!令 TT是Y字典keys裡的一員
If InStr(TT, "/") Then GoTo 666
'↑如果 TT裡有 "/"符號 ! 就跳到 666位置繼續執行
Crr = Y(TT)
'↑把Y字典以 TT 為key的陣列item呼叫出來
Cells(1, Y(TT & "/z") + 1).Interior.Color = Val(Split(TT, "|")(0))
'↑令第一列儲存格底色顏色是Y字典裡item的值
Cells(1, Y(TT & "/z") + 1).Interior.TintAndShade = Val(Split(TT, "|")(1))
'↑令第一列儲存格底色顏色深淺是Y字典裡item的值
Cells(2, Y(TT & "/z") + 1) = Y(TT & "/a")
'↑令第二列儲存格是Y字典裡item的值(加總值)
Cells(3, Y(TT & "/z") + 1).Resize(Y(TT & "/r"), 1) = Crr
'↑令第三列儲存格逐欄貼入收集到的數字
666
Next
Cells.Columns.AutoFit
'↑全部欄位自動調整欄寬
Cells.Borders.LineStyle = 1
'↑全部儲存格格線為細實線
MsgBox Timer - T & " 秒"
End Sub
Sub test()
Dim Arr, Brr(1 To 10000, 1 To 100), xD, R&, C%, Sh
Dim xR As Range, x%, y$, x1%, j%, crl, T
T = Timer
Set xD = CreateObject("Scripting.Dictionary")
Set Sh = Sheets("操作表")
R = Sh.UsedRange.EntireRow.Rows.Count
C = Sh.UsedRange.EntireColumn.Columns.Count
Set Arr = Range(Sh.[a1], Sh.Cells(R, C))
For Each xR In Arr
If IsNumeric(xR.Value) = False Or xR.Value = "" Then GoTo 888
crl = xR.Interior.Color
y = 2
If xD.Exists(crl) Then
y = xD(crl): x1 = xD(crl & "_C")
Brr(2, x1) = Brr(2, x1) + xR.Value
Brr(y + 1, x1) = xR.Value
xD(crl) = y + 1
Else
x = x + 1: Brr(1, x) = crl: Brr(2, x) = xR.Value
y = y + 1: Brr(y, x) = xR.Value
xD(crl) = y: xD(crl & "_C") = x
End If
888: Next
Workbooks.Add
[a1] = "顏色→": [A2] = "數字加總→": [A3] = "↓以下是明細"
[b1].Resize(1000, x) = Brr
For j = 1 To x: Cells(1, j + 1).Interior.Color = Brr(1, j): Next
Range(Cells(1, 2), Cells(1, x + 1)) = ""
Cells.Columns.AutoFit
Cells.Borders.LineStyle = 1
MsgBox Timer - T & " 秒"
End Sub作者: Andy2483 時間: 2022-11-4 10:19
