[發問] 如何利用VBA按鍵，將指定日期填滿顏色?

RCRG

問題
如何利用VBA按鍵，將指定日期填滿顏色?

問題詳細內容
C欄(C3開始)同一種料號裡，對應F欄若只有今天日期(目前先假設為2016/11/9，之後會以公式 =TODAY() 取代)，則填滿紅色；
對應F欄若 "只有" 今天與任一天，兩種日期，則填滿粉紅色(將任一天日期填滿粉紅色即可)；


註
A欄 "篩選例外料號" 功能說明：
在A欄輸入料號，該料號縱使符合填滿(粉)紅色條件也不填滿顏色

以上問題，請各位VBA高人參考附件幫解，感謝萬分。

附件下載
如何利用VBA按鍵，將指定日期填滿顏色.rar (16.38 KB)

下載次數: 20

2016-11-17 01:25

Andy2483

回復 10# 准提部林


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

執行前:

下載 (227.96 KB)

2023-5-10 09:07

執行結果:

下載 (217.11 KB)

2023-5-10 09:07

Sub 填色()
Dim xDic, xR As Range, TR, CC%
'↑宣告變數
If Not IsDate([C1]) Then MsgBox "日期時間未輸入! ": Exit Sub
'↑檢測[C1]需要輸入正確日期時間
Set xDic = CreateObject("Scripting.Dictionary")
'↑令xDic是字典
For Each xR In Range([A1], [A65536].End(xlUp))
'↑設逐項迴圈!令xR是A欄的儲存格
    If xR.Row > 1 And xR <> "" Then xDic(xR.Value) = Array(99, 0, 0)
    '↑例外料號,以99為識別碼
    '以xR儲存格值為key,item是一維陣列,0索引號值是99
Next
For Each xR In Range([C3], [C65536].End(xlUp))
'↑設逐項迴圈!令xR是C欄的儲存格
    If xR = "" Or Not IsDate(xR(1, 4)) Then GoTo 101
    '↑如果無料號或非日期,跳到101標示位置繼續執行
    TR = xDic(xR.Value)
    '↑令TR變數是xR變數查xDic字典回傳的item值(取出字典檔ITEM)
    If Not IsArray(TR) Then TR = Array(0, 0, 0)
    '↑如果TR變數還不是陣列!就令TR變數是一維陣列(首次入字典者, 放入預設陣列)
    If TR(0) = 99 Then GoTo 101
    '↑如果識別碼為99, 表示為例外, 或不符規則,跳到101標示位置繼續執行
    If xR(1, 4) > [C1] And TR(1) = 0 Then TR(0) = TR(0) + 10: TR(1) = 1
    '↑如果xR儲存格(含)右側第4格大於[C1]儲存格時間,而且1索引號TR陣列是0 !
    '就令0索引號TR陣列值累加10(是0加10為識別碼),令1索引號TR陣列值是1
    If xR(1, 4) < [C1] Then
    '↑如果日期欄值小於[C1]值時?
       If TR(2) = 0 Then TR(0) = TR(0) + 1: TR(2) = Int(xR(1, 4))
       '↑TR陣列2索引號值若為0, 表示為第1個日期,填入日期, 識別碼加1
       If Int(xR(1, 4)) <> TR(2) Then TR(0) = 99
       '↑若日期不相同, 表示小于C1日期超過2個,以99為識別碼
    End If
    xDic(xR.Value) = TR
    '↑以xR儲存格值當key,item是TR變數(一維陣列),納入xDic字典
101: Next
For Each xR In Range([C3], [C65536].End(xlUp))
'↑設逐項迴圈!令xR是C欄的儲存格
    If xR = "" Or Not IsDate(xR(1, 4)) Then GoTo 102
    '↑如果無料號或非日期,跳到102標示位置繼續執行
    TR = xDic(xR.Value): CC = 0
    '↑令TR變數盛出 xR儲存格值在xDic字典裡的item(一維陣列):令CC變數歸零
    If TR(0) = 10 Then CC = 3
    '↑如果只有大于C1日期 ,0索引號TR陣列值是10(識別碼 = 10),就令CC變數是3
    If TR(0) = 11 And xR(1, 4) < [C1] Then CC = 7
    '↑如果有大于C1日期, 且小于C1日期只有一個, 識別碼=10+1),就令CC變數是7
    If CC > 0 Then xR.Resize(1, 4).Interior.ColorIndex = CC
    '↑上底色
102: Next
End Sub

准提部林

回復 16# RCRG


xR(1, 4) C欄右第4格, 為F欄, 類推~~~

RCRG

回復 13# 准提部林

今天趁著空檔試用了一下准大的版本，完全符合我需要的，真的很謝謝幫了大忙；

想請教一下，我把日期錯貼到F欄，現在想改到G欄，請問要如何修改VBA呢?

葉國洲

回復 14# RCRG

Selection.FormulaR1C1 = ""這行下面再加
Selection.interior.color = xlnone

RCRG

回復 2# 葉國洲


    請問一下，下面是一鍵清除VBA，但沒辦法連填滿的顏色也恢復成白色，
請問要如何寫才能一鍵就使範圍內恢復空白原狀呢??

Sub 一鍵清空()
    Range("B3:U1000").Select
    Range("B3:U1000").Activate
    Selection.FormulaR1C1 = ""   
    Sheets("測試頁").Select
    Range("B2").Select
    [B1] = ""
MsgBox "清除完成！"
End Sub

准提部林

回復 12# RCRG


～～當然如果C1欄我能夠用 =NOW()，整個準確度的效果會對我更好，但目前看來兩位大大的VBA我只能填入=TODAY()　

程式是用　日+時間　去比對前後，要不要再多試？？？
至少下載範例檔看吧！
　

RCRG

回復 11# 葉國洲
回復 10# 准提部林


謝謝兩位大大的回答，這就是我想要的效果，抱歉把問題表達的這麼令人費解....XD
簡單來講就是，假設現在的時間點之後都是 "炸彈"，而現在的時間點之前每筆都是盾牌，
盾牌越來越少，少到一定數量，便會出現"粉紅色"提醒我；
當盾牌都沒了，只剩炸彈(現在以後時間點)，就會出現紅色提醒我；
不知道這樣譬喻會不會很奇怪...QQ

當然如果C1欄我能夠用 =NOW()，整個準確度的效果會對我更好，但目前看來兩位大大的VBA我只能填入=TODAY()，
真的很謝謝葉大和准大解答，受用無窮，感激不盡！

葉國洲

回復 9# RCRG
看看這樣可以嗎

1. Sub ex()
   
2. Dim d, d1, rng() As Range, arr, i%, j%, rng1 As Range
   
3. For i = 3 To Cells(Rows.Count, 3).End(xlUp).Row
   
4. If Right(Cells(i, 3), 1) = ChrW(160) Then
   
5. Cells(i, 3).Replace ChrW(160), ""
   
6. End If
   
7. Next i
   
8. Set d = CreateObject("scripting.dictionary")
   
9. Set d1 = CreateObject("scripting.dictionary")
   
10. With Sheets("測試頁")
    
11. Set rng1 = .Range("a2:a" & .Cells(Rows.Count, 1).End(xlUp).Row)
    
12. arr = .Range("c3:f" & .Cells(Rows.Count, 3).End(xlUp).Row)
    
13. .Range("c3:f" & .Cells(Rows.Count, 3).End(xlUp).Row).Interior.Color = xlNone
    
14.     For i = 1 To UBound(arr)
    
15.         d(arr(i, 1)) = d(arr(i, 1)) + 1
    
16.     Next i
    
17.     ReDim rng(1 To d.Count)
    
18.     t = d.items
    
19.     For i = 1 To d.Count
    
20.         k = k + t(i - 1)
    
21.         Set rng(i) = .Range(.Cells(2 + k - t(i - 1) + 1, 3), .Cells(2 + k, 6))
    
22.         If WorksheetFunction.CountIf(rng(i), ">" & .Range("c1")) = rng(i).Rows.Count And _
    
23.             WorksheetFunction.CountIf(rng1, rng(i).Cells(1, 1)) = 0 Then
    
24.             rng(i).Interior.Color = 255
    
25.         ElseIf WorksheetFunction.CountIf(rng(i), ">" & .Range("c1")) < rng(i).Rows.Count And _
    
26.                WorksheetFunction.CountIf(rng(i), ">" & .Range("c1")) <> 0 Then
    
27.             For j = 1 To rng(i).Rows.Count
    
28.                 If rng(i).Cells(j, 4) < Range("c1") Then
    
29.                     spr = Split(rng(i).Cells(j, 4), " ")(0)
    
30.                     d1(spr) = d1(spr) + 1
    
31.                 End If
    
32.             Next j
    
33.              k1 = d1.keys
    
34.              If d1.Count = 1 Then
    
35.                For j = 1 To rng(i).Rows.Count
    
36.                  If rng(i).Cells(j, 4) < .Range("c1") And WorksheetFunction.CountIf(rng1, rng(i).Cells(1, 1)) = 0 Then
    
37.                     rng(i).Rows(j).Interior.Color = 16711935
    
38.                  End If
    
39.                Next j
    
40.              End If
    
41.           End If
    
42.         d1.RemoveAll
    
43.     Next i
    
44. End With
    
45. End Sub

複製代碼

准提部林

規則看起來混亂, 大約寫一下, 眼睛已受不了, 若還有誤差, 等其他大大來吧!

1. Sub 填色()
   
2. Dim xDic, xR As Range, TR, CC%
   
3. If Not IsDate([C1]) Then MsgBox "日期時間未輸入! ": Exit Sub
   
4. Set xDic = CreateObject("Scripting.Dictionary")
   
5. For Each xR In Range([A1], [A65536].End(xlUp))
   
6.     If xR.Row > 1 And xR <> "" Then xDic(xR.Value) = Array(99, 0, 0) '例外料號,以99為識別碼
   
7. Next
   
8. 
   
9. For Each xR In Range([C3], [C65536].End(xlUp))
   
10.     If xR = "" Or Not IsDate(xR(1, 4)) Then GoTo 101 '無料號或非日期,略過
    
11.     TR = xDic(xR.Value) '取出字典檔ITEM
    
12.     If Not IsArray(TR) Then TR = Array(0, 0, 0) '首次入字典者, 放入預設陣列
    
13.     If TR(0) = 99 Then GoTo 101 '識別碼為99, 表示為例外, 或不符規則, 略過
    
14.     If xR(1, 4) > [C1] And TR(1) = 0 Then TR(0) = TR(0) + 10: TR(1) = 1 '大于C1, 加10為識別碼
    
15.     If xR(1, 4) < [C1] Then '小于C1時
    
16.        If TR(2) = 0 Then TR(0) = TR(0) + 1: TR(2) = Int(xR(1, 4)) '陣列第3個若為0, 表示為第1個日期,填入日期, 識別碼加1
    
17.        If Int(xR(1, 4)) <> TR(2) Then TR(0) = 99 '若日期不相同, 表示小于C1日期超過2個,以99為識別碼
    
18.     End If
    
19.     xDic(xR.Value) = TR
    
20. 101: Next
    
21. 
    
22. For Each xR In Range([C3], [C65536].End(xlUp))
    
23.     If xR = "" Or Not IsDate(xR(1, 4)) Then GoTo 102
    
24.     TR = xDic(xR.Value): CC = 0
    
25.     If TR(0) = 10 Then CC = 3 '只有大于C1日期, 識別碼=10
    
26.     If TR(0) = 11 And xR(1, 4) < [C1] Then CC = 7 '有大于C1日期, 且小于C1日期只有一個, 識別碼=10+1
    
27.     If CC > 0 Then xR.Resize(1, 4).Interior.ColorIndex = CC
    
28. 102: Next
    
29. End Sub

複製代碼

Xl0000012.rar (15.7 KB)

下載次數: 16

2016-11-19 13:19