麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 自動上底色與字色並自動調整反差易於識別 [打印本頁]

作者: Andy2483 時間: 2022-11-10 08:48 標題: 自動上底色與字色並自動調整反差易於識別

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

原始資料:
[attach]35481[/attach]

Interior_ColorIndex 方式結果:
[attach]35482[/attach]

Interior_Color方式設定底色 .深底色的字還沒變白色:
[attach]35483[/attach]

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 時間: 2022-11-11 11:57

本帖最後由 Andy2483 於 2022-11-11 12:04 編輯

謝謝各位前輩
找到方法:
[attach]35484[/attach]

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 時間: 2022-11-11 12:54

回復 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 時間: 2022-11-11 20:08

對比色的計算問題,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 時間: 2022-11-14 09:13

回復 4# quickfixer

謝謝前輩指導
以下是執行過說明與心得註解:
執行前:
[attach]35485[/attach]

執行結果:
[attach]35486[/attach]

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

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)