返回列表 上一主題 發帖

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

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

TurnR.png
2022-10-7 17:51



TurnR.rar (10.83 KB)

本帖最後由 Andy2483 於 2022-10-8 13:06 編輯

回復 1# maiko


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

原始:
2022-10-08_125316.JPG
2022-10-8 13:01


結果:
2022-10-08_125336.JPG
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

TOP

隨意窩 "EXCEL迷"  blog  或https://blog.xuite.net/hcm19522/twblog
已收集8500篇 EXCEL函數

TOP

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



    感謝幫助!

TOP

回復  maiko


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



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

TOP

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

TOP

回復 4# maiko


    另解=(VLOOKUP($A2,$I:$K,2,1)=A$1)+(VLOOKUP($A2,$I:$K,3,1)=A$1)
隨意窩 "EXCEL迷"  blog  或https://blog.xuite.net/hcm19522/twblog
已收集8500篇 EXCEL函數

TOP

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



    謝謝前輩指正
後學檢討修正與檢測如下:
原始 工作表1 有上色的儲存格畫面:
20221011-1.JPG
2022-10-11 08:56


另複製一份工作表 命名為 工作表N 全無底色:
20221011-2.JPG
2022-10-11 08:58


執行程式碼後 即並排做比較:
20221011-3.jpg
2022-10-11 08:59


滾動滑鼠做比較2:
20221011-4.jpg
2022-10-11 09:01


滾動滑鼠做比較3:
20221011-5.jpg
2022-10-11 09:02


滾動滑鼠做比較4:
20221011-6.jpg
2022-10-11 09:02


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

TOP

回復 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

TOP

回復  maiko


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

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



    感謝幫助,學到很多東西!

TOP

        靜思自在 : 人生不一定球球是好球,但是有歷練的強打者,隨時都可以揮棒。
返回列表 上一主題