我想为我的Excel工作表中的数据上色:
我需要分别查看每一行,并为具有相等数据值的单元格上色相同的颜色。
下面的代码对前10行中的所有数据进行迭代,并对每个单元格进行不同的着色。我不确定该如何记住有色单元格及其颜色,如果当前单元格已在该行的列表中被记住,则应用该颜色而不是新颜色。
在vba中有什么可用作动态列表吗?如何?
Sub Test1()
Dim x As Integer, rowInt As Integer, color As Integer
Application.ScreenUpdating = False
For rowInt = 1 To 10
color = 3
'numRows = number of cells before the first blank cell in the row ("A" & rowInt)
numRows = Range("A" & rowInt, Range("A" & rowInt).End(xlToRight)).Columns.Count
If numRows >= 16384 Then
numRows = 1
End If
Range("A" & rowInt).Select
For x = 1 To numRows
With Selection.Interior
.ColorIndex = color
.Pattern = xlSolid
End With
color = color + 1
ActiveCell.Offset(0, 1).Select
Next
Next
Application.ScreenUpdating = True
End Sub
您可以使用字典来捕获唯一值的颜色索引
Option Explicit
Public Sub ColorUniquesByRows()
Const START_ROW = 2
Dim ur As Range, arr As Variant, clrIndex As Long, i As Long, j As Long, ci As Long
Dim cArr As Variant, r As Long, g As Long, b As Long, a As Double, d As Object
Set ur = Sheet1.UsedRange 'Or ThisWorkbook.Worksheets("Sheet1").UsedRange
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
arr = ur
clrIndex = 3
For i = START_ROW To UBound(arr) 'Iterate each row
For j = 1 To UBound(arr, 2) 'Iterate each column (in current row)
If Len(arr(i, j)) > 0 Then 'Ignore empty cells
If Not d.Exists(arr(i, j)) Then 'Capture color index for each unique value
If clrIndex > 56 Then clrIndex = 3 'More than 56 columns - reset indx
ci = ThisWorkbook.Colors(clrIndex) 'Determine font color vs clr index
r = ci Mod 256: g = ci \ 256 Mod 256: b = ci \ 65536 Mod 256
a = 1 - ((0.299 * r) + (0.587 * g) + (0.144 * b)) / 255
d(arr(i, j)) = clrIndex & " " & IIf(a < 0.5, vbBlack, vbWhite)
clrIndex = clrIndex + 1
End If
cArr = Split(d(arr(i, j)))
With ur.Cells(i, j)
.Interior.colorIndex = cArr(0)
.Font.Color = cArr(1)
End With
End If
Next j
clrIndex = 3 'moving to next row: reset color index and dictionary object
Set d = CreateObject("Scripting.Dictionary")
Next i
Application.ScreenUpdating = True
End Sub
注意:这也会根据背景颜色确定字体颜色
结果
本文收集自互联网,转载请注明来源。
如有侵权,请联系[email protected] 删除。
我来说两句