Excel2007表格中如何让颜色按亮度差自动快速填充？（截图图片比较大）
发布网友
发布时间：2022-04-24 14:01
共3个回答
热心网友
时间：2023-10-15 12:35
因为有HSL颜色，而Excel设置后读取的颜色只是RGB颜色，所以要写VBA用来做两种颜色表示的换算。
下面代码放在 VBA模块中，使用方法及要求：
亮度放在第三行（就像你的图上表示的）
最开始的颜色统一放在D列，上图一会是D一会是E列，这样不好，要放一列上
先选中G4~AM4，视图——查看宏——选中SetColor——执行
再向下选中下一行G5~AM5，……同上执行，每次只选中1行的单元格。
如果行数太多，也可以改一下代码，全部选中可以一次都执行完。
' 颜色转换算法
' RGB2HSL
' HSL2RGB
'
'================================
Private Type HSL
H As Double ' 0-360
S As Double ' 0-1
L As Double ' 0-1
End Type
Private Type Colour
R As Double ' 0-1
G As Double ' 0-1
B As Double ' 0-1
End Type
' Calculate HSL from RGB
' Hue is in degrees
' Lightness is between 0 and 1
' Saturation is between 0 and 1
Private Function RGB2HSL(C1 As Colour) As HSL
Dim themin As Double, themax As Double, delta As Double
Dim c2 As HSL
themin = MinD(C1.R, MinD(C1.G, C1.B))
themax = MaxD(C1.R, MaxD(C1.G, C1.B))
delta = themax - themin
c2.L = (themin + themax) / 2
c2.S = 0
If ((c2.L > 0) And (c2.L < 1)) Then
If (c2.L < 0.5) Then
c2.S = delta / (2 * c2.L)
Else
c2.S = delta / (2 - 2 * c2.L)
End If
End If
c2.H = 0
If (delta > 0) Then
If ((themax = C1.R) And (themax <> C1.G)) Then _
c2.H = c2.H + (C1.G - C1.B) / delta
If ((themax = C1.G) And (themax <> C1.B)) Then _
c2.H = c2.H + (2 + (C1.B - C1.R) / delta)
If ((themax = C1.B) And (themax <> C1.R)) Then _
c2.H = c2.H + (4 + (C1.R - C1.G) / delta)
c2.H = c2.H * 60
End If
RGB2HSL = c2
End Function
' Calculate RGB from HSL, reverse of RGB2HSL()
' Hue is in degrees
' Lightness is between 0 and 1
' Saturation is between 0 and 1
Private Function HSL2RGB(C1 As HSL) As Colour
Dim c2 As Colour, sat As Colour, ctmp As Colour
Do While (C1.H < 0)
C1.H = C1.H + 360
Loop
Do While (C1.H > 360)
C1.H = C1.H - 360
Loop
If (C1.H < 120) Then
sat.R = (120 - C1.H) / 60
sat.G = C1.H / 60
sat.B = 0
ElseIf (C1.H < 240) Then
sat.R = 0
sat.G = (240 - C1.H) / 60
sat.B = (C1.H - 120) / 60
Else
sat.R = (C1.H - 240) / 60
sat.G = 0
sat.B = (360 - C1.H) / 60
End If
sat.R = MinD(sat.R, 1)
sat.G = MinD(sat.G, 1)
sat.B = MinD(sat.B, 1)
ctmp.R = 2 * C1.S * sat.R + (1 - C1.S)
ctmp.G = 2 * C1.S * sat.G + (1 - C1.S)
ctmp.B = 2 * C1.S * sat.B + (1 - C1.S)
If (C1.L < 0.5) Then
c2.R = C1.L * ctmp.R
c2.G = C1.L * ctmp.G
c2.B = C1.L * ctmp.B
Else
c2.R = (1 - C1.L) * ctmp.R + 2 * C1.L - 1
c2.G = (1 - C1.L) * ctmp.G + 2 * C1.L - 1
c2.B = (1 - C1.L) * ctmp.B + 2 * C1.L - 1
End If
HSL2RGB = c2
End Function
Private Function MinD(ByVal inA As Double, ByVal inB As Double) As Double
If (inA < inB) Then MinD = inA Else MinD = inB
End Function
Private Function MaxD(ByVal inA As Double, ByVal inB As Double) As Double
If (inA > inB) Then MaxD = inA Else MaxD = inB
End Function
Function NewColour(aR As Double, aG As Double, aB As Double) As Colour
With NewColour
.R = aR
.G = aG
.B = aB
End With
End Function
Sub SetColor()
'从单元格orgRange获取颜色值，转换为Excel中的HSL颜色
'取其中的H和S数值，L数值来自Excel中第三行的指定
'
Dim iRng As Range
Set orgRange = ActiveSheet.Range("D" & Selection.Row)
Dim rgbColor As Colour, hslColor As HSL
Dim H As Integer, S As Integer, L As Double
Dim orgColor As Long, newColor As Long
orgColor = orgRange.Interior.Color
rgbColor = NewColour((orgColor Mod 256) / 255, ((orgColor \ 256) Mod 256) / 255, (orgColor \ 256 \ 256) / 255)
hslColor = RGB2HSL(rgbColor)
For Each iRng In Selection
hslColor.L = ActiveSheet.Cells(3, iRng.Column).Value / 255 '更改HSL颜色中的亮度变量
'生产新的颜色值
rgbColor = HSL2RGB(hslColor)
newColor = RGB(CLng(rgbColor.R * &HFF), CLng(rgbColor.G * &HFF), CLng(rgbColor.B * &HFF))
iRng.Interior.Color = newColor
Next
End Sub
热心网友
时间：2023-10-15 12:35
条件格式---新建规则
热心网友
时间：2023-10-15 12:36
这个只能用VBA的方法，利用Range.Interior.Color = RGB(R,G,B)的方法，对指定区域自动填充
