[發問] 自動上底色與字色 並自動調整反差易於識別

Andy2483

各位前輩好
今天請教底色與字色的問題
1.由於較新版excel的底色字色設定比較多樣性!希望能自動讓底色字色設定自動調整反差易於識別
2.以下以 Interior_ColorIndex 方式 表達題意!
3.請教各位前輩有什麼方式可以 Interior_Color的方式設定底色方式,也可以自動讓底色字色設定自動調整反差?
因為顏色號種類太多了! 有什麼規則可循嗎?
20221110.zip (56.09 KB)

下載次數: 5

2022-11-10 08:38

原始資料:

下載 (117.3 KB)

2022-11-10 08:39

Interior_ColorIndex 方式結果:

下載 (102.86 KB)

2022-11-10 08:40

Interior_Color方式設定底色 .深底色的字還沒變白色:

下載 (90.94 KB)

2022-11-10 08:43

Option Explicit
Sub Interior_ColorIndex()
Dim Arr, R&, C&, Sh, Brr, Crr, i&, x&, Y, T, Zn, N
Set Y = CreateObject("Scripting.Dictionary")
T = Timer
Set Sh = Sheets("操作表")
R = Sh.UsedRange.EntireRow.Rows.Count
C = Sh.UsedRange.EntireColumn.Columns.Count
Arr = Range(Sh.[A1], Sh.Cells(R, C))
For i = 1 To R
   Zn = Arr(i, 1)
   If Y.Exists(Zn) = 0 Then
     N = N + 1
     Y(Zn) = N
   End If
   Sh.Cells(i, 1).Interior.ColorIndex = Y(Zn)
   If InStr("/1/3/5/9/10/11/12/13/18/21/23/25/26/29/30/31/32/41/47/49/51/52/53/54/55/56/", "/" & Y(Zn) & "/") Then
      Sh.Cells(i, 1).Font.ColorIndex = 2
   End If
Next
End Sub

Option Explicit
Sub Interior_Color()
Dim Arr, R&, C&, Sh, Brr, Crr, i&, x&, Y, T, Zn, N
Set Y = CreateObject("Scripting.Dictionary")
T = Timer
Set Sh = Sheets("操作表")
R = Sh.UsedRange.EntireRow.Rows.Count
C = Sh.UsedRange.EntireColumn.Columns.Count
Arr = Range(Sh.[A1], Sh.Cells(R, C))
For i = 1 To R
   Zn = Arr(i, 1)
   If Y.Exists(Zn) = 0 Then
     N = N + 100000
     Y(Zn) = N
   End If
   Sh.Cells(i, 1).Interior.Color = Y(Zn)
Next
End Sub

Andy2483

謝謝各位前輩
找到方法:

下載 (118.11 KB)

2022-11-11 11:55

Option Explicit
Sub Interior_Color()
Dim Arr, R&, C&, Sh, Brr, Crr, i&, X&, Y, T, Zn, N
Set Y = CreateObject("Scripting.Dictionary")
T = Timer
Set Sh = Sheets("操作表")
R = Sh.UsedRange.EntireRow.Rows.Count
C = Sh.UsedRange.EntireColumn.Columns.Count
Arr = Range(Sh.[A1], Sh.Cells(R, C))
For i = 1 To R
   Zn = Arr(i, 1)
   If Y.Exists(Zn) = 0 Then
     N = N + 100000
     Y(Zn) = N
   End If
   Sh.Cells(i, 1).Interior.Color = Y(Zn)
   Y(Zn) = Sh.Cells(i, 1).Interior.ColorIndex
   If InStr("/1/3/5/9/10/11/12/13/18/21/23/25/26/29/30/31/32/41/47/49/51/52/53/54/55/56/", "/" & Y(Zn) & "/") Then
      Sh.Cells(i, 1).Font.ColorIndex = 2
   End If
Next
End Sub
後學腦筋笨笨的!

Andy2483

回復 2# Andy2483


    Sorry!高興過頭了!後面的底色都錯了!

修正:再多用一個變數

Option Explicit
Sub Interior_Color()
Dim Arr, R&, C&, Sh, Brr, Crr, i&, X&, Y, T, Zn, N
Set Y = CreateObject("Scripting.Dictionary")
T = Timer
Set Sh = Sheets("操作表")
R = Sh.UsedRange.EntireRow.Rows.Count
C = Sh.UsedRange.EntireColumn.Columns.Count
Arr = Range(Sh.[A1], Sh.Cells(R, C))
For i = 1 To R
   Zn = Arr(i, 1)
   If Y.Exists(Zn) = 0 Then
     N = N + 100000
     Y(Zn) = N
   End If
   Sh.Cells(i, 1).Interior.Color = Y(Zn)
   X = Sh.Cells(i, 1).Interior.ColorIndex
   If InStr("/1/3/5/9/10/11/12/13/18/21/23/25/26/29/30/31/32/41/47/49/51/52/53/54/55/56/", "/" & X & "/") Then
      Sh.Cells(i, 1).Font.ColorIndex = 2
   End If
Next
End Sub

quickfixer

對比色的計算問題,google來的參數
Sub test()
    With Sheets("操作表")
        For i = 1 To 5000
            .Cells(i, 1).Font.Color = -vbWhite * (77 * (.Cells(i, 1).Interior.Color Mod &H100) + 151 * ((.Cells(i, 1).Interior.Color \ &H100) Mod &H100) + 28 * ((.Cells(i, 1).Interior.Color \ &H10000) Mod &H100) < 32640)
        Next i
    End With
End Sub

Andy2483

回復 4# quickfixer


    謝謝前輩指導
以下是執行過說明與心得註解:
執行前:

下載 (85.87 KB)

2022-11-14 09:09

執行結果:

下載 (85.32 KB)

2022-11-14 09:10

Sub test_quickfixer()
Dim i
    With Sheets("操作表")
        For i = 1 To 5000
            .Cells(i, 1).Font.Color = -vbWhite * (77 * (.Cells(i, 1).Interior.Color Mod &H100) + 151 * ((.Cells(i, 1).Interior.Color \ &H100) Mod &H100) + 28 * ((.Cells(i, 1).Interior.Color \ &H10000) Mod &H100) < 32640)
            '↑儲存格字色 = (-1) * 白色色彩常數16777215 * 判斷式( TURE=1 ,FALSE=0 )
            '這判斷式不知道如何解讀 ??
            
            '不過學到很多知識"
            '1.&H100:是一個常數 256
            '2.&H10000:是一個常數 65536
            '3..Cells(i, 1).Interior.Color / &H100=390.625 ,.Cells(i, 1).Interior.Color \ &H100=390
            '第一次學習到 運算式裡 \ = Int( / ) :除式的商去尾 取整數
        Next i
    End With
End Sub