麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 如何利用VBA按鍵，將指定日期填滿顏色? [打印本頁]

作者: RCRG 時間: 2016-11-17 01:26 標題: 如何利用VBA按鍵，將指定日期填滿顏色?

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

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

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

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

附件下載
[attach]25827[/attach]

作者: 葉國洲 時間: 2016-11-17 15:46

Sub test()
Dim d,d1,m%,n%,i%,j%,Rng, found
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Range("c3:f" & Cells(Rows.Count, 3).End(xlUp).Row).Interior.Color = xlNone
For i = 3 To Range("c3").End(xlDown).Row
d(Cells(i, 3).Value) = ""
Next i
k = d.keys
For i = 0 To UBound(k)
For j = 3 + n To Range("c3").End(xlDown).Row
If k(i) = Cells(j, 3) Then
m = m + 1
n = n + 1
Else
Set Rng = Cells(j - m, 3).Resize(m, 4)
For Each Cell In Rng.Range(Cells(1, 4), Cells(Rng.Rows.Count, 4))
If CDate(Split(Cell.Value, " ")(0)) = Date Then
found = True
d1(Split(Cell.Value, " ")(0)) = ""
Else
d1(Split(Cell.Value, " ")(0)) = ""
End If
Next Cell
k1 = d1.keys
Select Case d1.Count
Case 1
If CDate(k1(0)) = Date Then
Rng.Interior.Color = 255
End If
Case 2
If found = True Then
For ii = 1 To Rng.Rows.Count
If CDate(Split(Rng.Cells(ii, 4), " ")(0)) <> Date Then
Rng.Cells(ii, 1).Resize(1, 4).Interior.Color = 16711935
End If
Next ii
End If
Case Else
If found = True Then
For ii = 1 To Rng.Rows.Count
If CDate(Split(Rng.Cells(ii, 4), " ")(0)) = Date Then
Rng.Cells(ii, 1).Resize(1, 4).Interior.Color = 255
End If
Next ii
End If
End Select
m = 0
found = False
d1.RemoveAll
Exit For
End If
Next j
Next i
If Range("a2") <> "" Then
Set Rng = Range("c3:c" & Cells(Rows.Count, 3).End(xlUp).Row)
For i = 1 To Rng.Rows.Count
If Rng.Cells(i) = Range("a2") Then
Rng.Resize(i, 4).Interior.Color = xlNone
End If
Next i
End If
End Sub

複製代碼

回復 1# RCRG

作者: RCRG 時間: 2016-11-17 23:21

回復 2# 葉國洲

請問我把您的VBA貼在模組後執行，但似乎不行呢? 是我手法有錯誤嗎?

[attach]25838[/attach]

[attach]25839[/attach]

作者: 葉國洲 時間: 2016-11-18 01:49

測試資料𥚃沒有當天日期，所以不會填充顏色
請自行輸入當天日期，再執行程式

作者: RCRG 時間: 2016-11-18 10:48

回復 4# 葉國洲

恩恩，有了！
所以C1欄一定要是 "真的" 今天日期，VBA才會觸發嗎? 如果是輸入其他日期來 "假設" 為今天，這樣就不行嗎?
對了C1這欄位我想用鎖定把它保護起來，怕人家去修改到，但一鎖定VBA好像就跑不了了，能幫解決嗎?

另外 "篩選例外料號" 好像有點問題，我在A欄填入要忽略的料號，但其他料號也跟著受影響而不見了！晚上我再把圖片貼上來；

最後我的原問題想要再做點修改，不知可不可以，如下紅色字部分

問題詳細內容
C欄(C3開始)同一種料號裡，對應F欄若只有今天日期(或今天以後的日期)，則填滿紅色；
對應F欄若 "只有" 今天(或今天以後日期)與任一天，兩種日期，則填滿粉紅色(將任一天日期填滿粉紅色即可)；

反正就是今天以後日期(含今天)，都當成是今天就對了，晚上我也會一起附異動檔上來；

在此也先謝謝葉大了！

作者: 葉國洲 時間: 2016-11-18 13:59

回復 5# RCRG
我完全沒有考慮到C1儲存格,C1有任何變動是不會影響到程式的
有要做修改的部分,請隨附件上模擬你要的結果,光字面上說明,有
時不一定每個人都能明白你真正的需求,或有時別人會誤解你的恴思

作者: RCRG 時間: 2016-11-18 20:13

回復 6# 葉國洲

異常1
如下圖，這邊是不該出現反紅的，因為只有"今天"日期才需反紅，但該料號是有多種日期的。
[attach]25847[/attach]

作者: RCRG 時間: 2016-11-18 20:19

回復 6# 葉國洲

異常2
如下圖，在A欄 "例外篩選料號" 處，輸入該料號，應該是會忽略所有條件而不反紅或反粉紅，但是該筆卻反粉紅色了

[attach]25848[/attach]

作者: RCRG 時間: 2016-11-18 21:05

回復 6# 葉國洲

回復葉國洲

恩恩，有了！
所以C1欄一定要是 "真的" 今天日期，VBA才會觸發嗎? 如果是輸入其他日期來 ...
RCRG 發表於 2016-11-18 10:48

另外，我想更動的原問題內容，在此附上圖片與檔案，如下；
異動問題詳細內容
C欄(C3開始)同一種料號裡，對應F欄若"只有" 現在之後時間 "即C1欄的=NOW()" 的日期(最小時間單位會到分秒)，則填滿紅色；
對應F欄若 "只有" 現在之後時間與現在之前時間，共兩種日期或 "只有" 同種今天日期但兩個現在時間前後時間點，則填滿粉紅色；

[attach]25852[/attach]

異動後附件
[attach]25853[/attach]

作者: 准提部林 時間: 2016-11-19 13:19

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

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

複製代碼

[attach]25855[/attach]

作者: 葉國洲 時間: 2016-11-20 11:02

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

Sub ex()
Dim d, d1, rng() As Range, arr, i%, j%, rng1 As Range
For i = 3 To Cells(Rows.Count, 3).End(xlUp).Row
If Right(Cells(i, 3), 1) = ChrW(160) Then
Cells(i, 3).Replace ChrW(160), ""
End If
Next i
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
With Sheets("測試頁")
Set rng1 = .Range("a2:a" & .Cells(Rows.Count, 1).End(xlUp).Row)
arr = .Range("c3:f" & .Cells(Rows.Count, 3).End(xlUp).Row)
.Range("c3:f" & .Cells(Rows.Count, 3).End(xlUp).Row).Interior.Color = xlNone
For i = 1 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) + 1
Next i
ReDim rng(1 To d.Count)
t = d.items
For i = 1 To d.Count
k = k + t(i - 1)
Set rng(i) = .Range(.Cells(2 + k - t(i - 1) + 1, 3), .Cells(2 + k, 6))
If WorksheetFunction.CountIf(rng(i), ">" & .Range("c1")) = rng(i).Rows.Count And _
WorksheetFunction.CountIf(rng1, rng(i).Cells(1, 1)) = 0 Then
rng(i).Interior.Color = 255
ElseIf WorksheetFunction.CountIf(rng(i), ">" & .Range("c1")) < rng(i).Rows.Count And _
WorksheetFunction.CountIf(rng(i), ">" & .Range("c1")) <> 0 Then
For j = 1 To rng(i).Rows.Count
If rng(i).Cells(j, 4) < Range("c1") Then
spr = Split(rng(i).Cells(j, 4), " ")(0)
d1(spr) = d1(spr) + 1
End If
Next j
k1 = d1.keys
If d1.Count = 1 Then
For j = 1 To rng(i).Rows.Count
If rng(i).Cells(j, 4) < .Range("c1") And WorksheetFunction.CountIf(rng1, rng(i).Cells(1, 1)) = 0 Then
rng(i).Rows(j).Interior.Color = 16711935
End If
Next j
End If
End If
d1.RemoveAll
Next i
End With
End Sub

複製代碼

作者: RCRG 時間: 2016-11-21 10:39

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

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

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

作者: 准提部林 時間: 2016-11-21 10:50

本帖最後由准提部林於 2016-11-21 10:52 編輯

回復 12# RCRG

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

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

作者: RCRG 時間: 2016-11-23 00:00

回復 2# 葉國洲

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

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

作者: 葉國洲 時間: 2016-11-23 12:02

回復 14# RCRG

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

作者: RCRG 時間: 2016-11-24 21:58

回復 13# 准提部林

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

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

作者: 准提部林 時間: 2016-11-25 09:49

回復 16# RCRG

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

作者: Andy2483 時間: 2023-5-10 09:10

回復 10# 准提部林

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

執行前:
[attach]36324[/attach]

執行結果:
[attach]36325[/attach]

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

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)