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)
收藏 分享

葉國洲

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

論壇榮譽勳章論壇贊助勳章
2#
發表於 2016-11-17 15:46 | 只看該作者
  1. Sub test()
  2. Dim d,d1,m%,n%,i%,j%,Rng, found
  3. Set d = CreateObject("scripting.dictionary")
  4. Set d1 = CreateObject("scripting.dictionary")
  5. Range("c3:f" & Cells(Rows.Count, 3).End(xlUp).Row).Interior.Color = xlNone
  6. For i = 3 To Range("c3").End(xlDown).Row
  7.     d(Cells(i, 3).Value) = ""
  8. Next i
  9. k = d.keys
  10. For i = 0 To UBound(k)
  11.     For j = 3 + n To Range("c3").End(xlDown).Row
  12.         If k(i) = Cells(j, 3) Then
  13.             m = m + 1
  14.             n = n + 1
  15.         Else
  16.             Set Rng = Cells(j - m, 3).Resize(m, 4)
  17.             For Each Cell In Rng.Range(Cells(1, 4), Cells(Rng.Rows.Count, 4))
  18.                 If CDate(Split(Cell.Value, " ")(0)) = Date Then
  19.                     found = True
  20.                     d1(Split(Cell.Value, " ")(0)) = ""
  21.                 Else
  22.                     d1(Split(Cell.Value, " ")(0)) = ""
  23.                 End If
  24.             Next Cell
  25.                 k1 = d1.keys
  26.             Select Case d1.Count
  27.                 Case 1
  28.                     If CDate(k1(0)) = Date Then
  29.                     Rng.Interior.Color = 255
  30.                     End If
  31.                 Case 2
  32.                     If found = True Then
  33.                         For ii = 1 To Rng.Rows.Count
  34.                             If CDate(Split(Rng.Cells(ii, 4), " ")(0)) <> Date Then
  35.                                 Rng.Cells(ii, 1).Resize(1, 4).Interior.Color = 16711935
  36.                             End If
  37.                         Next ii
  38.                     End If
  39.                 Case Else
  40.                     If found = True Then
  41.                         For ii = 1 To Rng.Rows.Count
  42.                             If CDate(Split(Rng.Cells(ii, 4), " ")(0)) = Date Then
  43.                                 Rng.Cells(ii, 1).Resize(1, 4).Interior.Color = 255
  44.                             End If
  45.                         Next ii
  46.                     End If
  47.             End Select
  48.             m = 0
  49.             found = False
  50.             d1.RemoveAll
  51.             Exit For
  52.         End If
  53.     Next j
  54. Next i
  55. If Range("a2") <> "" Then
  56. Set Rng = Range("c3:c" & Cells(Rows.Count, 3).End(xlUp).Row)
  57.     For i = 1 To Rng.Rows.Count
  58.        If Rng.Cells(i) = Range("a2") Then
  59.        Rng.Resize(i, 4).Interior.Color = xlNone
  60.        End If
  61.     Next i
  62. End If
  63. End Sub
複製代碼
回復 1# RCRG

TOP

RCRG
　暱稱: RCRG滾奶滾企

中學生Rank: 2

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

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

TOP

葉國洲

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

論壇榮譽勳章論壇贊助勳章
4#
發表於 2016-11-18 01:49 | 只看該作者
測試資料&#153219;沒有當天日期，所以不會填充顏色
請自行輸入當天日期，再執行程式

TOP

RCRG
　暱稱: RCRG滾奶滾企

中學生Rank: 2

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

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

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

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

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

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

在此也先謝謝葉大了！

TOP

葉國洲

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

論壇榮譽勳章論壇贊助勳章
6#
發表於 2016-11-18 13:59 | 只看該作者
回復 5# RCRG
我完全沒有考慮到C1儲存格,C1有任何變動是不會影響到程式的
有要做修改的部分,請隨附件上模擬你要的結果,光字面上說明,有
時不一定每個人都能明白你真正的需求,或有時別人會誤解你的恴思

TOP

RCRG
　暱稱: RCRG滾奶滾企

中學生Rank: 2

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

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

TOP

RCRG
　暱稱: RCRG滾奶滾企

中學生Rank: 2

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

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

TOP

RCRG
　暱稱: RCRG滾奶滾企

中學生Rank: 2

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


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



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



異動後附件
異動版_如何利用VBA按鍵，將指定日期填滿顏色.rar (16.47 KB)

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-23 
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
返回列表 上一主題