[發問] 某個範圍內依據條件填上顏色

maiko

下載 (77.15 KB)

2022-10-7 17:51

TurnR.rar (10.83 KB)

下載次數: 6

2022-10-7 17:52

Andy2483

回復 1# maiko


    謝謝前輩發表此主題與範例
請前輩試看看
今天習得
WorksheetFunction.Max()
CDate()
Format(date, "dddd")
Union()
練習陣列與字典

原始:

下載 (331.48 KB)

2022-10-8 13:01

結果:

下載 (319.8 KB)

2022-10-8 13:01

Option Explicit
Sub 搜尋變色()
Dim xA, Arr, Ra As Range, i&, x&, T, Ts, T1, T2, Tn
Dim xD, Rng As Range, Ct
'↑宣告變數

Set xD = CreateObject("Scripting.Dictionary")
'↑令xD是字典

Set xA = [A1].CurrentRegion.Offset(1, 0)
'↑將xA儲存格設為 ([A1]相鄰非空格所串連起來的儲存格,
'擴展到方正區域的最小範圍,
'往下偏移一列 )

Arr = [I1].CurrentRegion.Offset(1, 0)
'↑將 ([I1]相鄰非空格所串連起來的儲存格,
'擴展到方正區域的最小範圍,
'往下偏移一列 ),
'倒入Arr陣列中

Arr(UBound(Arr), 1) = CDate(WorksheetFunction.Max(xA))
'↑令Arr陣列的最左下角那格是xA儲存格裡的最大值
'並轉換為日期 YYYY/M/D 在陣列中呈現

For i = 1 To UBound(Arr) - 1
'↑設定迴圈將Arr這些被搜尋的日期範圍與J.K欄關鍵字組成字串當KEY
'倒入xD陣列中,ITEM設為6(ITEM設>0的數字就可以!因為ITEM沒有用到)

   Ts = Arr(i, 1)
   Tn = Arr(i + 1, 1)
   T1 = Arr(i, 2)
   T2 = Arr(i, 3)
   T = Tn - Ts
   For x = 0 To T
      xD(Ts + x & T1) = 6
      xD(Ts + x & T2) = 6
   Next
Next
For Each Ra In xA
'↑設定迴圈將xA裡的儲存格組成字串,
'(YYYY/M/D&Weekday)之後
'到xD字典裡查看看是否查得到,
'如果有就把儲存格放入Rng儲存格集裡

   Ct = Ra & Format(Ra, "dddd")
   If xD(Ct) Then
      If Rng Is Nothing Then
         Set Rng = Ra
         Else
            Set Rng = Union(Rng, Ra)
      End If
   End If
Next
Rng.Interior.ColorIndex = 38
'↑最後把儲存格集的底色變更為想要的顏色

End Sub

hcm19522

https://blog.xuite.net/hcm19522/twblog/590574845

maiko

hcm19522 發表於 2022-10-8 15:41

    感謝幫助！

maiko

回復  maiko


    謝謝前輩發表此主題與範例
請前輩試看看
今天習得
WorksheetFunction.Max()
CDa ...
Andy2483 發表於 2022-10-8 13:04

    你好，在2022-02-07這個星期應該是 Tuesday        Wednesday 這兩天的，但是2022-02-07 Monday也填上顏色，有這麼的小小錯誤。
不過還是感謝你的幫助！

Andy2483

回復 5# maiko
謝謝前輩指導
後學只一股腦練習技巧
後學沒做好驗證的程序
謝謝前輩幫忙做了驗證
謝謝

hcm19522

回復 4# maiko


    另解=(VLOOKUP($A2,$I:$K,2,1)=A$1)+(VLOOKUP($A2,$I:$K,3,1)=A$1)

Andy2483

你好，在2022-02-07這個星期應該是 Tuesday        Wednesday 這兩天的，但是2022-02-07 Monday也填上顏 ...
maiko 發表於 2022-10-9 06:05

    謝謝前輩指正
後學檢討修正與檢測如下:
原始 工作表1 有上色的儲存格畫面:

下載 (362.61 KB)

2022-10-11 08:56

另複製一份工作表 命名為 工作表N 全無底色:

下載 (345.25 KB)

2022-10-11 08:58

執行程式碼後 即並排做比較:

下載 (370.39 KB)

2022-10-11 08:59

滾動滑鼠做比較2:

下載 (345.68 KB)

2022-10-11 09:01

滾動滑鼠做比較3:

下載 (334.33 KB)

2022-10-11 09:02

滾動滑鼠做比較4:

下載 (298.11 KB)

2022-10-11 09:02

謝謝前輩指導!
再有錯也請再指導!

Andy2483

回復 5# maiko


    今天習得同檔案,不同工作表!開心視窗並排目視比較
心得如下:

Option Explicit
Sub 搜尋變色()
Dim xA, Arr, Ra As Range, i&, x&, T, Ts, T1, T2, Tn
Dim xD, Rng As Range, Ct, Awn
'↑宣告變數

Set xD = CreateObject("Scripting.Dictionary")
'↑令xD是字典

Set xA = Sheets("工作表N").[A1].CurrentRegion.Offset(1, 0)
'↑將xA儲存格設為 ([A1]相鄰非空格所串連起來的儲存格,
'擴展到方正區域的最小範圍,
'往下偏移一列 )

Arr = [I1].CurrentRegion.Offset(1, 0)
'↑將 ([I1]相鄰非空格所串連起來的儲存格,
'擴展到方正區域的最小範圍,
'往下偏移一列 ),
'倒入Arr陣列中

Arr(UBound(Arr), 1) = CDate(WorksheetFunction.Max(xA) + 1)
'↑令Arr陣列的最左下角那格是xA儲存格裡的最大值
'並轉換為日期 YYYY/M/D 在陣列中呈現

'↑這裡是犯錯的地方!需要再加1,才能涵蓋xA範圍裡的最大日期

For i = 1 To UBound(Arr) - 1
'↑設定迴圈將Arr這些被搜尋的日期範圍與J.K欄關鍵字組成字串當KEY
'倒入xD陣列中,ITEM設為6(ITEM設>0的數字就可以!因為ITEM沒有用到)

   Ts = Arr(i, 1)
   Tn = Arr(i + 1, 1)
   T1 = Arr(i, 2)
   T2 = Arr(i, 3)
   T = Tn - Ts - 1
   '↑這裡也是犯錯的地方!少減了1
   
   For x = 0 To T
      xD(Ts + x & T1) = 0.1
      xD(Ts + x & T2) = 0.1
   Next
Next
For Each Ra In xA
'↑設定迴圈將xA裡的儲存格組成字串,
'(YYYY/M/D&Weekday)之後
'到xD字典裡查看看是否查得到,
'如果有就把儲存格放入Rng儲存格集裡

   Ct = Ra & Format(Ra, "dddd")
   If xD(Ct) Then
      If Rng Is Nothing Then
         Set Rng = Ra
         Else
            Set Rng = Union(Rng, Ra)
      End If
   End If
Next
xA.Interior.ColorIndex = xlNone
'↑把A:G欄的色全部變為無底色

Rng.Interior.ColorIndex = 38
'↑最後把儲存格集的底色變更為想要的顏色

Awn = ActiveWorkbook.Name
'↑令Awn是本檔的檔名

ActiveWindow.NewWindow
'↑將本檔再開另一個視窗

Sheets("工作表1").Activate
'↑這視窗顯示在 "工作表1" 工作表上

Windows.CompareSideBySideWith Awn & ":1"
'↑讓兩個視窗並排比較

Windows.SyncScrollingSideBySide = True
'↑讓兩個視窗同時滾動做比較
   
End Sub

maiko

回復  maiko


    今天習得同檔案,不同工作表!開心視窗並排目視比較
心得如下:

Option Explicit
...
Andy2483 發表於 2022-10-11 09:11

    感謝幫助，學到很多東西！