且构网

分享程序员开发的那些事...
且构网 - 分享程序员编程开发的那些事

Excel:将单元格的背景颜色更改为在该单元格中写入的RGB颜色

更新时间:2023-02-13 16:52:56



编辑(到期信用):我看到



注意:我没有做任何错误处理。我相信你可以照顾这个。


I have this code which shows rgb color of target cell:

Function getRGB(RefCell)
Dim mystr As String
Application.Volatile
    mystr = Right("000000" & Hex(RefCell.Interior.Color), 6)
    getRGB = Application.Hex2Dec(Right(mystr, 2)) & ", " & _
             Application.Hex2Dec(Mid(mystr, 3, 2)) & ", " & _
             Application.Hex2Dec(Left(mystr, 2))
End Function

I need that this code instead of showing off rgb of other cell, would change background color of its own cell. Maybe anyone know how to do it?

The MSDN KB says

A user-defined function called by a formula in a worksheet cell cannot change the environment of Microsoft Excel. This means that such a function cannot do any of the following: Insert, delete, or format cells on the spreadsheet.

That unfortunately is incorrect!!!

YOU CAN change the color of the cell from where the formula is called. Here is an example. This will change the color of the cell to Red from where the formula is called.

The trick is to pass a blank value to the sub as the first parameter (a in the below case.)

Why does it work?

I don't know! But it works :)

Function SetIt(RefCell)
    RefCell.Parent.Evaluate "getRGB(" & """""" & "," & RefCell.Address(False, False) & ")"

    SetIt = ""
End Function

Sub getRGB(a As String, RefCell As Range)
    RefCell.Interior.ColorIndex = 3 '<~~ Change color to red
End Sub

ScreenShot

EDIT (Credit Where Due): I had seen this thread by Tim Williams long time ago and I had experimented with it and I had achieved lot of other things which that KB article says is not possible.

BTW I played more with it and I was able to make it work without passing a blank string.

Function SetIt(RefCell)
    RefCell.Parent.Evaluate "getRGB(" & RefCell.Address(False, False) & ")" 
    SetIt = ""
End Function

Sub getRGB(RefCell As Range)
    RefCell.Interior.ColorIndex = 3
End Sub

EDIT

Followup from Duplicate question and chat (Below comments)

Paste this in a code module and then in cell P20 paste the formula =setit(P20,N20)

Function SetIt(DestCell As Range, RefCell As Range)
    RefCell.Parent.Evaluate "SetAndGetRGB(" & RefCell.Address(False, False) & _
                                        "," & _
                                        DestCell.Address(False, False) & ")"

    SetIt = ""
End Function

Sub SetAndGetRGB(RefCell As Range, DestCell As Range)
    Dim sRGB As String
    Dim shName As String

    shName = Split(RefCell.Value, "!")(0)
    sRange = Split(RefCell.Value, "!")(1)

    sRGB = Right("000000" & Hex(Sheets(shName).Range(sRange).Interior.Color), 6)

    DestCell.Interior.Color = RGB( _
                                    Application.Hex2Dec(Right(sRGB, 2)), _
                                    Application.Hex2Dec(Mid(sRGB, 3, 2)), _
                                    Application.Hex2Dec(Left(sRGB, 2)) _
                                  )
End Sub

Note: I have not done any error handling. I am sure you can take care of that.