I'm trying to make it so that select cells within a group of data, can only be filled with 1 of 4 pre-selected colors. Kind of like a drop-down menu list but for fill colors instead.
We have a team of about 9 working within an excel file at the same time. Time is of the essence, and some of our communication and input to each other is with the color of fill for select data.
Since there are many colors available, we can get a strange mix of shades, hindering our production.
Is there a way to limit the fill colors to just a pre-selected group?
I've only researched Data Validation drop-down menus as that is the only thing my limited knowledge could think of.
With the ride range of data variables and form, have not found a way where Conditional Formatting would be possible. With our process, the data can remain the same but we communicate with colors on whether or not the data is valid and ready to go. The user needs to be able to change the cell color arbituarily.
Unfortunately I haven't come close to what I've been looking for.
Put this in the sheet module:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim StrColorbox01Name As String
Dim StrColorbox02Name As String
Dim StrColorbox03Name As String
Dim StrColorbox04Name As String
Dim StrActivatorName As String
Dim ObjColorbox01 As Object
Dim ObjColorbox02 As Object
Dim ObjColorbox03 As Object
Dim ObjColorbox04 As Object
Dim ObjActivator As Object
Dim DblSize As Double
StrColorbox01Name = "ObjCB01"
StrColorbox02Name = "ObjCB02"
StrColorbox03Name = "ObjCB03"
StrColorbox04Name = "ObjCB04"
StrActivatorName = "ObjActivator"
DblSize = 15
On Error Resume Next
Set ObjColorbox01 = Me.Shapes(StrColorbox01Name)
Set ObjColorbox02 = Me.Shapes(StrColorbox02Name)
Set ObjColorbox03 = Me.Shapes(StrColorbox03Name)
Set ObjColorbox04 = Me.Shapes(StrColorbox04Name)
Set ObjActivator = Me.Shapes(StrActivatorName)
On Error GoTo 0
If ObjColorbox01 Is Nothing Or ObjColorbox02 Is Nothing Or ObjColorbox03 Is Nothing Or ObjColorbox04 Is Nothing Or ObjActivator Is Nothing Then
On Error Resume Next
ObjColorbox01.Delete
ObjColorbox02.Delete
ObjColorbox03.Delete
ObjColorbox04.Delete
ObjActivator.Delete
On Error GoTo 0
With Me.Shapes
Set ObjColorbox01 = .AddShape(msoShapeRectangle, 0, 0, DblSize, DblSize)
Set ObjColorbox02 = .AddShape(msoShapeRectangle, ObjColorbox01.Left + ObjColorbox01.Width, ObjColorbox01.Top, ObjColorbox01.Width, ObjColorbox01.Height)
Set ObjColorbox03 = .AddShape(msoShapeRectangle, ObjColorbox02.Left + ObjColorbox02.Width, ObjColorbox02.Top, ObjColorbox02.Width, ObjColorbox02.Height)
Set ObjColorbox04 = .AddShape(msoShapeRectangle, ObjColorbox03.Left + ObjColorbox03.Width, ObjColorbox03.Top, ObjColorbox03.Width, ObjColorbox03.Height)
Set ObjActivator = .AddShape(msoShapeRectangle, ObjColorbox04.Left + ObjColorbox04.Width, ObjColorbox04.Top, ObjColorbox04.Width, ObjColorbox04.Height)
ObjColorbox01.Name = StrColorbox01Name
ObjColorbox02.Name = StrColorbox02Name
ObjColorbox03.Name = StrColorbox03Name
ObjColorbox04.Name = StrColorbox04Name
ObjActivator.Name = StrActivatorName
ObjColorbox01.DrawingObject.Interior.Color = RGB(255, 0, 0)
ObjColorbox02.DrawingObject.Interior.Color = RGB(0, 255, 0)
ObjColorbox03.DrawingObject.Interior.Color = RGB(0, 0, 255)
ObjColorbox04.DrawingObject.Interior.Color = RGB(255, 255, 0)
ObjActivator.DrawingObject.Interior.Color = RGB(127, 127, 127)
ObjColorbox01.OnAction = "SubColor01"
ObjColorbox02.OnAction = "SubColor02"
ObjColorbox03.OnAction = "SubColor03"
ObjColorbox04.OnAction = "SubColor04"
ObjActivator.OnAction = "SubColorPaletteOnOff"
ObjActivator.OLEFormat.Object.Caption = "ON"
With ObjActivator.OLEFormat.Object.ShapeRange.TextFrame2
.VerticalAnchor = msoAnchorMiddle
.HorizontalAnchor = msoAnchorNone
.MarginLeft = 0
.MarginRight = 0
.MarginTop = 0
.MarginBottom = 0
.WordWrap = msoFalse
.AutoSize = msoAutoSizeShapeToFitText
End With
End With
Else
Set ObjColorbox02 = Me.Shapes(StrColorbox02Name)
Set ObjColorbox03 = Me.Shapes(StrColorbox03Name)
Set ObjColorbox04 = Me.Shapes(StrColorbox04Name)
ObjColorbox01.Height = DblSize
ObjColorbox01.Width = DblSize
ObjColorbox02.Height = ObjColorbox01.Height
ObjColorbox02.Width = ObjColorbox01.Width
ObjColorbox03.Height = ObjColorbox01.Height
ObjColorbox03.Width = ObjColorbox01.Width
ObjColorbox04.Height = ObjColorbox01.Height
ObjColorbox04.Width = ObjColorbox01.Width
End If
If ObjActivator.OLEFormat.Object.Caption = "ON" Then
ObjColorbox01.Top = Target.Cells(1, 1).Top + Target.Cells(1, 1).Height
ObjColorbox01.Left = Target.Cells(1, 1).Left + Target.Cells(1, 1).Width
ObjColorbox02.Top = ObjColorbox01.Top
ObjColorbox02.Left = ObjColorbox01.Left + ObjColorbox01.Width
ObjColorbox03.Top = ObjColorbox02.Top
ObjColorbox03.Left = ObjColorbox02.Left + ObjColorbox02.Width
ObjColorbox04.Top = ObjColorbox03.Top
ObjColorbox04.Left = ObjColorbox03.Left + ObjColorbox03.Width
ObjActivator.Top = ObjColorbox04.Top
ObjActivator.Left = ObjColorbox04.Left + ObjColorbox04.Width
End If
End Sub
Put this in a public module:
Sub SubColor01()
If ActiveSheet.Shapes("ObjActivator").OLEFormat.Object.Caption = "ON" Then
Selection.Interior.Color = ActiveSheet.Shapes("ObjCB01").DrawingObject.Interior.Color
End If
End Sub
Sub SubColor02()
If ActiveSheet.Shapes("ObjActivator").OLEFormat.Object.Caption = "ON" Then
Selection.Interior.Color = ActiveSheet.Shapes("ObjCB02").DrawingObject.Interior.Color
End If
End Sub
Sub SubColor03()
If ActiveSheet.Shapes("ObjActivator").OLEFormat.Object.Caption = "ON" Then
Selection.Interior.Color = ActiveSheet.Shapes("ObjCB03").DrawingObject.Interior.Color
End If
End Sub
Sub SubColor04()
If ActiveSheet.Shapes("ObjActivator").OLEFormat.Object.Caption = "ON" Then
Selection.Interior.Color = ActiveSheet.Shapes("ObjCB04").DrawingObject.Interior.Color
End If
End Sub
Sub SubColorPaletteOnOff()
Dim StrColorbox01Name As String
Dim StrColorbox02Name As String
Dim StrColorbox03Name As String
Dim StrColorbox04Name As String
Dim StrActivatorName As String
Dim ObjColorbox01 As Object
Dim ObjColorbox02 As Object
Dim ObjColorbox03 As Object
Dim ObjColorbox04 As Object
Dim ObjActivator As Object
Dim RngRestingRange As Range
StrColorbox01Name = "ObjCB01"
StrColorbox02Name = "ObjCB02"
StrColorbox03Name = "ObjCB03"
StrColorbox04Name = "ObjCB04"
With ActiveSheet
Set ObjActivator = .Shapes("ObjActivator")
Set ObjColorbox01 = .Shapes(StrColorbox01Name)
Set ObjColorbox02 = .Shapes(StrColorbox02Name)
Set ObjColorbox03 = .Shapes(StrColorbox03Name)
Set ObjColorbox04 = .Shapes(StrColorbox04Name)
Set RngRestingRange = .Range("A1")
End With
With ObjActivator.OLEFormat.Object
Select Case .Caption
Case Is = "ON"
.Caption = "OFF"
ObjColorbox01.Top = RngRestingRange.Cells(1, 1).Top
ObjColorbox01.Left = RngRestingRange.Cells(1, 1).Left
ObjColorbox02.Top = ObjColorbox01.Top
ObjColorbox02.Left = ObjColorbox01.Left + ObjColorbox01.Width
ObjColorbox03.Top = ObjColorbox02.Top
ObjColorbox03.Left = ObjColorbox02.Left + ObjColorbox02.Width
ObjColorbox04.Top = ObjColorbox03.Top
ObjColorbox04.Left = ObjColorbox03.Left + ObjColorbox03.Width
ObjActivator.Top = ObjColorbox04.Top
ObjActivator.Left = ObjColorbox04.Left + ObjColorbox04.Width
Case Is = "OFF"
.Caption = "ON"
Case Else
.Caption = "OFF"
End Select
End With
End Sub
Main advantage: you can select multiple ranges as you like and change their fillings just with the clicks you need to select the wanted ranges plus one for the color.