Consulting

Results 1 to 2 of 2

Thread: Automatically defining cell background color via system date

  1. #1

    Automatically defining cell background color via system date

    For each cell in which I enter data on a given day, I'd like the cell's background color to be automatically defined by my computer's system date.

    When I go to:

    Fill -> Background -> Color -> More Colors

    I see an X-Y Color Palette. If I can set the Y coordinate as a function of month, and the x coordinate as a function of day, that would be perfect.

    I'd like all cells' background colors to stay constant after data entry, regardless of system date.

    Is there any way that I can do this in Excel?

    Thank you

  2. #2
    Mac Moderator VBAX Guru mikerickson's Avatar
    Joined
    May 2007
    Location
    Davis CA
    Posts
    2,778
    You could put this in the sheet's code module
    [VBA]Private Sub Worksheet_Change(ByVal Target As Range)
    Target.Interior.Color = RGBfromDate()
    End Sub[/VBA]
    and this in a normal module.
    [VBA]Function RGBfromDate()
    RGBfromDate = RGBfromXY(Day(Date) / 31 - 0.5, Month(Date) / 12 - 0.5)
    End Function

    Function RGBfromXY(xVal As Double, yVal As Double) As Double
    Dim Radius As Double, Angle As Double
    Radius = (xVal ^ 2 + yVal ^ 2) ^ 0.5
    If Radius > 1 Then Radius = 1
    If xVal <> 0 Then
    Angle = Atn(yVal / xVal) / Application.Pi() * 180
    If xVal < 0 Then Angle = Angle + 180
    ElseIf yVal > 0 Then
    Angle = 90
    Else
    Angle = 270
    End If
    If Angle < 0 Then Angle = Angle + 360
    RGBfromXY = RGBfromRTheta(Radius, Angle)
    End Function

    Function RGBfromRTheta(Radius As Double, theta As Double)
    Rem 0<=radius<=1, 0<=theta<=360
    Dim baseR As Double, baseG As Double, baseB As Double
    Dim antiR As Double, antiG As Double, antiB As Double
    Dim temp As Double

    temp = RGBfromDegree(theta, baseR, baseG, baseB)
    temp = RGBfromDegree(180 + theta, antiR, antiG, antiB)

    antiR = (1 - Radius) * antiR
    antiG = (1 - Radius) * antiG
    antiB = (1 - Radius) * antiB

    RGBfromRTheta = RGB(255 * (baseR + antiR), 255 * (baseG + antiG), 255 * (baseB + antiB))
    End Function

    Function RGBfromDegree(Angle As Double, ByRef Rval As Double, ByRef Gval As Double, ByRef Bval As Double) As Double
    Do Until Angle > 0
    Angle = Angle + 360
    Loop
    Angle = Angle Mod 360
    Select Case Angle
    Case Is <= 60
    Rval = 1
    Gval = Angle / 60
    Case Is <= 120
    Gval = 1
    Rval = (120 - Angle) / 60
    Case Is < 180
    Gval = 1
    Bval = (Angle - 120) / 60
    Case Is <= 240
    Bval = 1
    Gval = (240 - Angle) / 60
    Case Is <= 300
    Bval = 1
    Rval = (Angle - 240) / 60
    Case Else
    Rval = 1
    Bval = (360 - Angle) / 60
    End Select
    RGBfromDegree = RGB(255 * Rval, 255 * Gval, 255 * Bval)
    End Function[/VBA]

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •