15问答网 > Excel2007表格中如何让颜色按亮度差自动快速填充？（截图图片比较大）

Excel2007表格中如何让颜色按亮度差自动快速填充？（截图图片比较大）

2025-02-08 00:43:26

推荐回答（3个）

回答1：

因为有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

回答2：

条件格式---新建规则

回答3：

这个只能用VBA的方法，利用Range.Interior.Color = RGB(R,G,B)的方法，对指定区域自动填充

最新问答

为什么别人经常去美容院做脸的脸还缺水，说往脸上拍水会刺痛，我说我三十多岁没去过美容院做脸，她说我脸

由5个十，7个一，3个十分之一，4个千分之一组成的小数是多少

不锈钢弧形门框折边图纸……

怎么样才能哄性格比较内向的女生开心？

公告送达是指见报后60日，还是以交公告费之日开始计算？一般要多长时间才能见报?