[發問] 5.5秒! 求更準更快! (數字儲存格分底色加總)

Andy2483

各位前輩好
1.後學藉此主題初淺學習到儲存格底色顏色跟顏色深淺,謝謝各位前輩在論壇上提供範例與論述!感謝論壇!
2.請教10*100格 數字儲存格分底色加總 求前輩指正並指導
數字儲存格分底色加總_20221103.zip (42.79 KB)

下載次數: 6

2022-11-3 11:09

執行前:

下載 (281.22 KB)

2022-11-3 11:10

10*10000格的執行結果: 521 秒

下載 (150.21 KB)

2022-11-3 11:11

10*100格的執行結果: 5.5.秒

下載 (132.1 KB)

2022-11-3 11:12

Andy2483

學習總是跌跌撞撞!越遇挫折越勇敢向前!謝謝前輩們指導!
原以為轉置字典的item:Application.Transpose(Y.ITEMS)可以解決!
10*20格還可以順暢,增加到10*100格就無法轉置了:

下載 (130.7 KB)

2022-11-3 12:56

程式碼如下:
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

簡單將練習心得註解一下:
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

謝謝指正並指導!

samwang

回復 1# Andy2483


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

回復 4# samwang


    謝謝前輩指導
超短的時間!厲害!
以下是執行結果與心得註解,請前輩再指導!
後學對解決問題的啟始都無頭緒!亂試! 仿錯方法! 又模仿的四不像!
導致效率不彰! 自己的註解也錯註!
謝謝指導

第一列未清除時:

下載 (99.12 KB)

2022-11-4 10:02

最後結果:

下載 (170.37 KB)

2022-11-4 10:03

Option Explicit
Sub test_samwang()
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")
'↑令xD是字典
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位置繼續執行
    crl = xR.Interior.Color
    '↑另crl 是底色顏色號
    y = 2
    '↑令y 每次的迴圈初始值都是 2!這是Brr陣列裡的結果列數(以下稱_Brr結果列)
    '因為這是要從第3列開始放明細值!所以初始值是2讓後程序加 1=3!
    '此值倒入字典 xD(crl)後再繼續累加 1
    If xD.Exists(crl) Then
    '↑如果以 xR底色顏色號為KEY查察 xD字典是有此鍵!
        y = xD(crl)
        '↑條件成立!就令y 是字典裡對應key為 (xR底色顏色號)的item值
        x1 = xD(crl & "_C")
        '↑條件成立!就令x1 是字典裡對應key為 (xR底色顏色號& "_C")的item值
        'x1是在Brr陣列裡的結果欄數(以下稱_Brr結果欄)的意思
        Brr(2, x1) = Brr(2, x1) + xR.Value
        '↑條件成立!就讓Brr陣列裡(第2列/Brr結果欄)對應的位置值與 Arr儲存格_xR值累加
        Brr(y + 1, x1) = xR.Value
        '↑條件成立!就讓Brr陣列裡(第y變數+1列/Brr結果欄)對應的位置等於 Arr儲存格_xR值
        xD(crl) = y + 1
        '↑條件成立!Brr結果列累加 1
    Else
    '↑如果條件不成立! 迴圈的一開始條件不會成立! 第一次遇到不同底色 條件也不會成立!
        x = x + 1
        '↑x是短整數!初始值是0! 累加 1!這是 底色顏色號的種類數!
        '遇到字典裡沒有的 底色顏色號種類時!就要加 1
        Brr(1, x) = crl
        '↑Brr陣列(第一列/Brr結果欄1)值等於 底色顏色號
        Brr(2, x) = xR.Value
        '↑Brr陣列(第二列/Brr結果欄1)值等於 Arr儲存格_xR值(第一個數字加總值)
        y = y + 1
        '↑y的宣告是字串!數字字串是可以做數學運算的!超高興!學到了!
        'y的第一值是 "2" + 1 後是 "3"
        Brr(y, x) = xR.Value
        '↑Brr陣列(第三列/Brr結果欄1)值等於 Arr儲存格_xR值(第一個明細值)
        xD(crl) = y
        '↑把底色顏色號為key,倒入字典中,item是 3
        xD(crl & "_C") = x
        '↑把(底色顏色號 & "_C")字串 為key,倒入字典中,item是 前方的底色顏色號的種類數1
    End If
888: Next
Workbooks.Add
[a1] = "顏色→": [A2] = "數字加總→": [A3] = "↓以下是明細"
[B1].Resize(1000, x) = Brr
'↑從工作表[B1]開始貼入Brr陣列資料
For j = 1 To x
'↑設順迴圈!從1 到 底色顏色號的種類最後累加數
   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
看得懂是應該的!會用又是另一回事!勤練就對了!