如何將不同資料用不同顏色區分?

minarabbit

最近晚輩因業務上要處理大筆學生報名資料，學生會選填許多志願，
一位學生可能會有將近5筆的資料(報名不同科系)，所以總計起來會有將近千筆的資料。
為了方便在電腦上或紙本上檢核資料，會把同一位學生的資料用顏色區分(如附件內圖片3)。
晚輩上網查詢許多資料，大多數都是建議用"設定格式化的條件"去處理，但結果會如附件內圖片4的情況。
後來找到國外有人做出了VBA程式，可以將相同資料用顏色區分，多個資料可以區分開來(如附件國外VBA程式)。
但是當晚輩測試時，會出現以下2種情形:
1. 全選資料後，程式會順利跑完，但資料顏色出現混亂，如附件圖片1的情形。
2. 指定身分證欄位後，程式和Excel卡住，如附件圖片2的情形。

晚輩希望各位VBA高手能解答疑惑，能否如附件圖片3做顏色區分，顏色能夠不傷眼，且同一位學生資料採用一色，
顏色區分最多4種顏色，按照順序將學生資料做分類，感謝各位高手教導與回復。

准提部林

Sub TEST_A1()
Dim xR As Range, xH As Range, Cr, x%
Cr = Array(44, 37, 39, 43) '色號用"錄製"即可取得
With Range([f2], [a65536].End(3))
     .Interior.ColorIndex = xlNone
     Application.ScreenUpdating = False
     For Each xR In .Columns(4).Cells
         If xR <> xR(0) Then Set xH = xR(1, 0)
         If xR <> xR(2) Then
            Range(xH, xR).Interior.ColorIndex = Cr(x)
            x = x + 1: If x = 4 Then x = 0
         End If
     Next
End With
End Sub

Andy2483

回復 1# minarabbit
回復 2# 准提部林


    謝謝論壇,謝謝前輩發表此主題與範例
謝謝 准提部林前輩的方案常用不同的方法解決,後學如獲至寶
以下是方案學習心得註解,請前輩再指導

執行前:

下載 (141.63 KB)

2023-6-13 12:37

執行結果:

下載 (141.61 KB)

2023-6-13 12:37

Option Explicit
Sub TEST_A1()
Dim xR As Range, xH As Range, Cr, x%
'↑宣告變數
Cr = Array(44, 37, 39, 43) '色號用"錄製"即可取得
'↑令Cr變數是 一維陣列(4個陣列值:索引號0~3)
With Range([f2], [a65536].End(3))
'↑以下是關於 本表儲存格的程序
     .Interior.ColorIndex = xlNone
     '↑令儲存格底色是無色
     Application.ScreenUpdating = False
     '↑令螢幕畫面不隨程序執行結果做變化
     For Each xR In .Columns(4).Cells
     '↑設逐項迴圈!令xR變數是 該範圍第4欄儲存格
         If xR <> xR(0) Then Set xH = xR(1, 0)
         '↑如果xR儲存格值不等於上一格儲存格值!
         '就令xH變數是xR的左邊的儲存格
         If xR <> xR(2) Then
         '↑如果迴圈跑到 xR儲存格值不等於xR的下個儲存格值
            Range(xH, xR).Interior.ColorIndex = Cr(x)
            '↑就令xH與xR這範圍儲存格的底色上色
            x = x + 1: If x = 4 Then x = 0
            '↑令X變數從0~3做循環變化
         End If
     Next
End With
End Sub

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教

執行結果:

下載 (139.4 KB)

2023-6-13 13:21

Option Explicit
Sub TEST()
Dim Brr, A, Z, i&, N&, T$, T3$, T4$, xR As Range, K%
A = Array(37, 40, 38, 35)
'A = Array(37, 40, 38, 35, 36, 34) '可自行增加顏色
Set Z = CreateObject("Scripting.Dictionary")
[總表!C:D].Interior.ColorIndex = xlNone
Set xR = Range([總表!F1], [總表!A65536].End(3)): Brr = xR
For i = 2 To UBound(Brr)
   T3 = Brr(i, 3): T4 = Brr(i, 4): T = Brr(i, 1) & "|" & Brr(i, 2) & "|" & T3
   If Z(T4) = "" Then Z(T4) = T
   If Z(T) = "" Then Z(T) = T4
   If i - Z(T4 & "|") = 1 Or Z(T4 & "|") = "" Then Z(T4 & "|") = i Else: K = 1
   If Z(T4) <> T Then MsgBox "ID_" & T4 & " 資料異常": Exit Sub
   If Z(T) <> T4 Then MsgBox "校生_" & T & "  ID異常": Exit Sub
   T = T3 & "|" & T4
  If Z(T) = "" Then N = N + 1: Z(T) = A((N - 1) Mod (UBound(A) + 1))
   xR(i, 3).Resize(, 2).Interior.ColorIndex = Z(T)
Next
If K = 1 Then MsgBox "資料零散!建議重新排序!"
Set Z = Nothing: Set xR = Nothing: Erase Brr, A
End Sub

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案為 各校統計

執行結果:

下載 (24.22 KB)

2023-6-13 15:09

Option Explicit
Sub TEST_1()
Application.DisplayAlerts = False
Dim Brr, A%, B$, Z, i&, R&, T$, T2$, T3$, xR As Range
Set Z = CreateObject("Scripting.Dictionary")
Set xR = Range([總表!F1], [總表!A65536].End(3)): Brr = xR
For i = 2 To UBound(Brr)
   If i = 2 Then R = R + 1: Brr(1, 1) = "校別\人數": Brr(1, 2) = "人數": Brr(1, 3) = "Remark"
   T2 = Brr(i, 2): T3 = Brr(i, 3): T = T2 & "|" & T3
   If Z(T) <> "" Then: GoTo i01
   If Z(T2) = "" Then
      R = R + 1: Z(T2) = R: Brr(R, 1) = Brr(i, 2)
      Brr(R, 2) = 1: Brr(R, 3) = T3: Z(T) = 1: GoTo i01
   End If
   A = Brr(Z(T2), 2): A = A + 1: Brr(Z(T2), 2) = A
   B = Brr(Z(T2), 3): B = B & "," & T3: Brr(Z(T2), 3) = B
   Z(T) = 1
i01: Next
If R <= 1 Then MsgBox "無資料!": Exit Sub
On Error Resume Next
Sheets("各校統計").Delete
On Error GoTo 0
With Worksheets.Add(after:=Worksheets(Sheets.Count))
   .Name = "各校統計"
   With .[A1].Resize(R, 3)
      .Value = Brr: .EntireColumn.AutoFit
   End With
End With
Set Z = Nothing: Set xR = Nothing: Erase Brr
End Sub

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案為 比序1明細,請各位前輩指教

執行結果:

下載 (31.62 KB)

2023-6-13 16:21

Option Explicit
Sub TEST_2()
Application.DisplayAlerts = False
Dim Brr, Crr, A%, Z, i&, C%, T$, T2$, T3$, T5$, xR As Range, M&
Set Z = CreateObject("Scripting.Dictionary")
Set xR = Range([總表!F1], [總表!A65536].End(3)): Brr = xR
ReDim Crr(1 To UBound(Brr), 1 To 200)
For i = 2 To UBound(Brr)
   If i = 2 Then C = C + 1: Crr(1, 1) = "N0\比序1": Crr(2, 1) = 1
   T2 = Brr(i, 2): T3 = Brr(i, 3): T5 = Brr(i, 5): T = T3 & "|" & T5
   If Z(T) <> "" Then: GoTo i01
   If Z(T5) = "" Then
      C = C + 1: Z(T5) = C: Crr(1, C) = T5: Crr(2, C) = Brr(i, 4) & "/" & T3
      Z(T) = 1: Z(T5 & "|r") = 2: GoTo i01
   End If
   A = Z(T5 & "|r"): A = A + 1: Crr(A, Z(T5)) = Brr(i, 4) & "/" & T3
   Z(T5 & "|r") = A: Z(T) = 1
   If M < A Then M = A: Crr(M, 1) = M - 1
i01: Next
If C <= 1 Then MsgBox "無資料!": Exit Sub
On Error Resume Next
Sheets("比序1明細").Delete
On Error GoTo 0
With Worksheets.Add(after:=Worksheets(Sheets.Count))
   .Name = "比序1明細"
   With .[A1].Resize(M, C)
      .Value = Crr: .EntireColumn.AutoFit
   End With
End With
Set Z = Nothing: Set xR = Nothing: Erase Brr, Crr
End Sub
'=====================================
補充:
以下是比序2明細

執行結果:

下載 (32.16 KB)

2023-6-13 16:33

Sub TEST_3()
Application.DisplayAlerts = False
Dim Brr, Crr, A%, Z, i&, C%, T$, T2$, T3$, T6$, xR As Range, M&
Set Z = CreateObject("Scripting.Dictionary")
Set xR = Range([總表!F1], [總表!A65536].End(3)): Brr = xR
ReDim Crr(1 To UBound(Brr), 1 To 200)
For i = 2 To UBound(Brr)
   If i = 2 Then C = C + 1: Crr(1, 1) = "N0\比序1": Crr(2, 1) = 1
   T2 = Brr(i, 2): T3 = Brr(i, 3): T6 = Brr(i, 6): T = T3 & "|" & T6
   If Z(T) <> "" Then: GoTo i01
   If Z(T6) = "" Then
      C = C + 1: Z(T6) = C: Crr(1, C) = T6: Crr(2, C) = Brr(i, 4) & "/" & T3
      Z(T) = 1: Z(T6 & "|r") = 2: GoTo i01
   End If
   A = Z(T6 & "|r"): A = A + 1: Crr(A, Z(T6)) = Brr(i, 4) & "/" & T3
   Z(T6 & "|r") = A: Z(T) = 1
   If M < A Then M = A: Crr(M, 1) = M - 1
i01: Next
If C <= 1 Then MsgBox "無資料!": Exit Sub
On Error Resume Next
Sheets("比序2明細").Delete
On Error GoTo 0
With Worksheets.Add(after:=Worksheets(Sheets.Count))
   .Name = "比序2明細"
   With .[A1].Resize(M, C)
      .Value = Crr: .EntireColumn.AutoFit
   End With
End With
Set Z = Nothing: Set xR = Nothing: Erase Brr, Crr
End Sub

minarabbit

回復 2# 准提部林

  謝謝准提部林大大! 快速地解決了多筆資料分顏色的問題!
  和同事一起研究大大寫的程式，雖然有些比較專業的語法看不懂，
  但經過Andy2483前輩加上註解，我和同事可以在姓名和身分證欄位變動後
  仍可以順利地運行程式，而且還能把原本4種顏色增加到6種，這種學習的驚喜令我感到無比快樂!!

  再次感謝准提部林大大的教導，並感謝Andy2483前輩分享知識。

minarabbit

回復 3# Andy2483


    感謝Andy2483前輩分享，您的註解對想學習的我幫助很大，令我驚訝的是您後面還寫了好多程式，勤學的精神令晚輩佩服。

准提部林

上一個是"逐行"填色, 較慢//
這個是"分區"填色, 當資料較多時, 理論上會較快!!!
Sub TEST_A2()
Dim Arr, i&, R&, N&, S$, T$, x%, xA As Range, U(1 To 4) As Range
Cr = Array(0, 44, 37, 39, 43)
With Range([f2], [a65536].End(3)(2))
     .Interior.ColorIndex = xlNone
     Arr = .Value
End With
For i = 1 To UBound(Arr) - 1
    S = Arr(i, 4)
    If S <> T Then T = S: R = i + 1: N = 0
    N = N + 1
    If S <> Arr(i + 1, 4) Then
       x = x Mod 4 + 1: Set xA = Cells(R, "c").Resize(N, 2)
       If U(x) Is Nothing Then Set U(x) = xA Else Set U(x) = Union(U(x), xA)
       If U(x).Count > 100 Then U(x).Interior.ColorIndex = Cr(x): Set U(x) = Nothing
    End If
Next i
For x = 1 To 4
    If Not U(x) Is Nothing Then U(x).Interior.ColorIndex = Cr(x)
Next x
End Sub

Andy2483

回復 9# 准提部林
回復 8# minarabbit

謝謝 准提部林前輩再指導,謝謝 minarabbit前輩回復一起學習

後學藉此帖學習前輩的方案,方案學習心得註解如下,請前輩再指導


Option Explicit
Sub TEST_A2()
Dim Arr, Cr, i&, R&, N&, S$, T$, x%, xA As Range, U(1 To 4) As Range
'↑宣告變數:(Arr,Cr)是通用型變數,(i,R,N)是長整數,(S,T)是字串變數,
'x是短整數,xA是儲存格變數,U是一維陣列(陣列裡只能裝儲存格)
Cr = Array(0, 44, 37, 39, 43)
'↑令Cr變數是一維陣列,陣列裡5個數值(索引號0~4)
With Range([f2], [a65536].End(3)(2))
'↑以下是關於本表[F2]到A欄有內容儲存格下一格,這範圍儲存格的程序
     .Interior.ColorIndex = xlNone
     '↑這範圍儲存格底色是無色
     Arr = .Value
     '↑令Arr這通用型變數是 二維陣列,以範圍儲存格值帶入陣列中
End With
For i = 1 To UBound(Arr) - 1
'↑設順迴圈!i從1 到Arr陣列縱向第2大索引號
    S = Arr(i, 4)
    '↑令S這字串變數是 i迴圈列第4欄Arr陣列值
    If S <> T Then T = S: R = i + 1: N = 0
    '↑如果S變數值與 T這字串變數不同? True就令T變數是 S變數,
    '令R變數是 i迴圈數+1,令N變數是 0
    N = N + 1
    '↑令N變數累加 1
    If S <> Arr(i + 1, 4) Then
    '↑如果S變數不同於下方的Arr陣列值?
       x = x Mod 4 + 1: Set xA = Cells(R, "c").Resize(N, 2)
       '↑令x這短整數變數是 x自身除4的餘數 +1 數值,
       '↑令xA這儲存格變數是 同學生區域的儲存格,
       'Cells(R, "c")是此區域儲存格最左上角格,
       'Resize(N, 2)是向下擴展N格,向右擴展2格
       If U(x) Is Nothing Then Set U(x) = xA Else Set U(x) = Union(U(x), xA)
       '↑如果這U一維陣列的第x索引號陣列值是 沒有物件,
       '是就令U一維陣列的第x索引號陣列值是xA,
       '否則(意思是x號陣列值已經有儲存格),就令xA(儲存格)納入x號陣列值裡
       If U(x).Count > 100 Then U(x).Interior.ColorIndex = Cr(x): Set U(x) = Nothing
       '↑如果x號陣列值裡的儲存格大於100格? 是就令其底色是對應的色號,
       '然後令U一維陣列的第x號陣列值清空物件
    End If
Next i
For x = 1 To 4
    If Not U(x) Is Nothing Then U(x).Interior.ColorIndex = Cr(x)
Next x
'↑設順迴圈將每個 U一維陣列的陣列值(儲存格)底色是對應的色號,
'此迴圈是處理 小於等於100格的陣列值(儲存格)
End Sub