12
返回列表 上一主題 發帖

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

RCRG
　暱稱: RCRG滾奶滾企

中學生Rank: 2

帖子
95 
主題
24 
精華
0 
積分
118 
點名
0  
作業系統
XP 
軟體版本
Office 2003 
閱讀權限
20 
性別
男 
註冊時間
2015-11-10 
最後登錄
2020-5-25 
1# 跳轉到 » 正序看帖
打印
tT
發表於 2016-11-17 01:26 | 只看該作者

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

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

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


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

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

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

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1446 
主題
40 
精華
0 
積分
1470 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-10-21 
18#
發表於 2023-5-10 09:10 | 只看該作者
回復 10# 准提部林


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

執行前:


執行結果:



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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-21 
17#
發表於 2016-11-25 09:49 | 只看該作者
回復 16# RCRG


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

TOP

RCRG
　暱稱: RCRG滾奶滾企

中學生Rank: 2

帖子
95 
主題
24 
精華
0 
積分
118 
點名
0  
作業系統
XP 
軟體版本
Office 2003 
閱讀權限
20 
性別
男 
註冊時間
2015-11-10 
最後登錄
2020-5-25 
16#
發表於 2016-11-24 21:58 | 只看該作者
回復 13# 准提部林

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

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

TOP

葉國洲

帖子
31 
主題
0 
精華
0 
積分
31 
點名
0  
作業系統
win10 
軟體版本
office 2016 
閱讀權限
10 
性別
男 
註冊時間
2016-10-4 
最後登錄
2017-10-17 

論壇榮譽勳章論壇贊助勳章
15#
發表於 2016-11-23 12:02 | 只看該作者
回復 14# RCRG

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

TOP

RCRG
　暱稱: RCRG滾奶滾企

中學生Rank: 2

帖子
95 
主題
24 
精華
0 
積分
118 
點名
0  
作業系統
XP 
軟體版本
Office 2003 
閱讀權限
20 
性別
男 
註冊時間
2015-11-10 
最後登錄
2020-5-25 
14#
發表於 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

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-21 
13#
發表於 2016-11-21 10:50 | 只看該作者
本帖最後由 准提部林 於 2016-11-21 10:52 編輯

回復 12# RCRG


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

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

TOP

RCRG
　暱稱: RCRG滾奶滾企

中學生Rank: 2

帖子
95 
主題
24 
精華
0 
積分
118 
點名
0  
作業系統
XP 
軟體版本
Office 2003 
閱讀權限
20 
性別
男 
註冊時間
2015-11-10 
最後登錄
2020-5-25 
12#
發表於 2016-11-21 10:39 | 只看該作者
回復 11# 葉國洲
回復 10# 准提部林


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

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

TOP

葉國洲

帖子
31 
主題
0 
精華
0 
積分
31 
點名
0  
作業系統
win10 
軟體版本
office 2016 
閱讀權限
10 
性別
男 
註冊時間
2016-10-4 
最後登錄
2017-10-17 

論壇榮譽勳章論壇贊助勳章
11#
發表於 2016-11-20 11:02 | 只看該作者
回復 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
複製代碼

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-21 
10#
發表於 2016-11-19 13:19 | 只看該作者
規則看起來混亂, 大約寫一下, 眼睛已受不了, 若還有誤差, 等其他大大來吧!
  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

  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

  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)

TOP

        靜思自在 : 有時當思無時苦，好天要積雨來糧。
12
返回列表 上一主題