Double click to change cell to multiple color or back to original

[one4youman]

Below is a piece of code from another thread where double clicking on a cell changes the cell to red. If you double click on the cell again it changes back to its original color format.

I am looking to see if there is a way to add additional colors to the choices. For Example, the first double click produces Green, second Red, third yellow, fourth gold, fifth white, and lastly the sixth would change it back to its original color.

Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, Cancel As Boolean)
'https://www.mrexcel.com/forum/excel-questions/634133-double-click-change-cell-colour.html
Static Fst      As Boolean
Static rng      As Range
Static ray
Dim c           As Long
Dim Dn          As Range
Dim Rw          As Long
    If Fst = False Then
        Set rng = ActiveSheet.UsedRange
        ReDim ray(1 To rng.Count, 1 To 2)
        For Each Dn In rng
            c = c + 1
            ray(c, 1) = Dn.Address: ray(c, 2) = Dn.Interior.ColorIndex
        Next Dn
        Fst = True
    End If
For Rw = 1 To UBound(ray)
    If ray(Rw, 1) = target.Address Then
        target.Interior.ColorIndex = IIf(target.Interior.ColorIndex = 3, ray(Rw, 2), 3)
    End If
Next Rw
End Sub

 

[one4youman]

Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, Cancel As Boolean)
'https://www.mrexcel.com/forum/excel-questions/634133-double-click-change-cell-colour.html
Static Fst      As Boolean
Static rng      As Range
Static ray
Dim c           As Long
Dim Dn          As Range
Dim Rw          As Long
    If Fst = False Then
        Set rng = ActiveSheet.UsedRange
        ReDim ray(1 To rng.Count, 1 To 2)
        For Each Dn In rng
            c = c + 1
            ray(c, 1) = Dn.Address: ray(c, 2) = Dn.Interior.ColorIndex
        Next Dn
        Fst = True
    End If
For Rw = 1 To UBound(ray)
    If ray(Rw, 1) = target.Address Then
        target.Interior.ColorIndex = IIf(target.Interior.ColorIndex = 3, ray(Rw, 2), 3)
    End If
Next Rw
End Sub

 

[My Aswer Is This]

What cell do you want to double click on?

 

[one4youman]

It would be either the entire sheet or maybe a range similar to A1:W15

 

[dreid1011]

What other options for original color are there besides no fill? Could it be one of the other colors mentioned or something else entirely?

 

[mikerickson]

Something like this. You can change or add colors or the sequence, but do allow for the Case Else so that odd colors will get the ball rolling.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    With Target
        If Not Application.Intersect(.Cells, Me.Range("A1:W15")) Is Nothing Then
            With .Interior
                Select Case .Color
                    Case vbRed
                    .Color = vbBlue
                    Case vbBlue
                    .Color = vbGreen
                    Case vbGreen
                    .Color = vbYellow
                    Case Else
                    .Color = vbRed
                End Select
            End With
            Cancel = True
        End If
    End With
End Sub

 

[one4youman]

The cell might have a custom color shade already which is the reason to allow it loop back to the original color of the cell.

 

[My Aswer Is This]

What was the original color?

 

[dreid1011]

The cell might have a custom color shade already which is the reason to allow it loop back to the original color of the cell.

That could get tricky if you interrupt the sequence on one cell and start clicking on another before going back to the first cell to finish clicking. Though, you could track the "default" colors on a hidden sheet and refer to that sheet to know what the original color was.