Color Selected (Single Click) Cell with a background color


I have a table of figures (total costs across department and month) that I act on with some VBA to provide additional information.  I'd like to be able to color the background of the selected cell within this range, so that the users clearly knows which month and department for which he is requesting additional information.  Is there a simple VBA code that will change the background color of a selected cell?
BBluAsked:
Who is Participating?
 
Ingeborg Hawighorst (Microsoft MVP / EE MVE)Connect With a Mentor Microsoft MVP ExcelCommented:
Hello,

changing the color of the cell upon click is independent of your existing macro. You'll need a Selection change event in the sheet. Picking up where rspahitz has started:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not intersect(target, range("t8:w13")) is nothing then
       With target.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = vbRed
       End With
end if
end sub

Open in new window


On top of that, you'd probably first want to clear any existing interior colors when another cell within t8:w13 is selected, so that when the selection changes, the cell color moves


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not intersect(target, range("t8:w13")) is nothing then
       Range("t8:w13").Interior.ColorIndex = xlNone
       With target.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = vbRed
       End With
end if
end sub

Open in new window


This code goes into the Sheet module of the sheet, not a standard module.

cheers, teylyn
0
 
rspahitzConnect With a Mentor Commented:
   With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = vbRed
    End With

Instead of vbRed, you can also use various color constants like vbYellow, vbGreen, etc, or actual numbers like 255 for red, 65535 for purple or &HFF0000 for green
0
 
BBluAuthor Commented:
Thanks, rspahitz.  Pardon my naivity, but would that be in a new module or in the "This Workbook" area (not sure what you call this)
0
Upgrade your Question Security!

Your question, your audience. Choose who sees your identity—and your question—with question security.

 
rspahitzConnect With a Mentor Commented:
I thought you already had VBA code and wanted to insert this.  

The answer depends on what triggers the need for the highlighting.  If you simply want to, for example, highlight columns B C and D of whatever the current row is, try this in the code window of the currnet sheet e.g. Sheet 1:

Private mPrevCell As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not mPrevCell Is Nothing Then
        Cells(mPrevCell.Row, 2).Interior.Pattern = xlNone
        Cells(mPrevCell.Row, 3).Interior.Pattern = xlNone
        Cells(mPrevCell.Row, 4).Interior.Pattern = xlNone
    End If
    SetColor ActiveCell.Row, 2, vbRed
    SetColor ActiveCell.Row, 3, vbYellow
    SetColor ActiveCell.Row, 4, vbGreen
    Set mPrevCell = ActiveCell
End Sub

Private Sub SetColor(RowNumber As Integer, ColumnNumber As Integer, BackColor As Long)
    With Cells(RowNumber, ColumnNumber).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = BackColor
    End With
End Sub


0
 
BBluAuthor Commented:
I'm actually working from within another bit of code that uses the selected cell to show details from another table.  Let me figure that out and send it over to you.  Thanks, again.
0
 
BBluAuthor Commented:
Okay, I got my other code to work.  Now, all I'd like to do is change the background color of the cell, if a single cell within the range t8:w13 is selected.  My code is messy, but I've included it just in case it might be helpful.
Sub CommandButton1_Click()
    Dim i As Long, lastRow As Long
    Dim rRow As Long, cCol As Long
    Dim mMonth As Long
    Dim rng As Range
    Dim wb1 As Workbook
    Dim Dept As String

    '~~> Change the range to the relevant range here
    If Intersect(Selection, Range("t8:w13")) Is Nothing Then
        'the intersect function checks to see if the selection exists in the given range
        MsgBox "Please select the cell in the correct range"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    'By setting ScreenUpdating to False at the Start of the macro, you will not only stop
    ' the constant screen flickering associated with recorded macro, but also greatly speed
    ' up the execution of the macro. The reason it speeds up code is because Excel no longer
    ' needs to repaint the screen whenever it encounters such commands as Select, Activate,
    ' LargeScroll, SmallScroll and many others.
   
     
    
   'Sheets("QB_Expenses").Activate
    lastRow = Sheets("QB_Expenses").Range("A" & Rows.Count).End(xlUp).Row
    ' finds last row in QB_Expenses Worksheet
 'MsgBox ("The last row is: " & lastRow)
    
   'This part tells the macro which dept/month combination we are working with
   rRow = Selection.Row
  'MsgBox ("The row is: " & rRow)
    cCol = Selection.Column
  '  MsgBox ("The column is: " & cCol)
    mMonth = Month(Cells(7, cCol).Value)
    'What month are we looking for?
    'The month columns are all in row 7
    Dept = Cells(rRow, 14).Value
    'What Dept are we looking for
    'The Departments rows are all in column 14
    'MsgBox (mMonth & "/" & Dept)
    'Creating new table in memory?
    'MsgBox (Month(Sheets("QB_Expenses").Range("c" & 2).Value))
    'MsgBox ("compare to Month" & mMonth)
    'MsgBox (Sheets("QB_Expenses").Range("d" & 2).Value)
    'MsgBox ("comare to Dept" & Dept)
    
    Set rng = Sheets("QB_Expenses").Range("A1:G1")
    'On Error GoTo ErrorCatch
    
    For i = 2 To lastRow
        If Month(Sheets("QB_Expenses").Range("C" & i).Value) = mMonth _
        And _
        Sheets("QB_Expenses").Range("D" & i).Value = Dept Then
           Set rng = Union(rng, Sheets("QB_Expenses").Range("A" & i & ":G" & i))
           'if the month and dept match, add this column to the open workbook
           
        End If
    Next i
    
    Sheets("QB_Expenses").Range(rng.Address).Copy
     Set wb1 = Workbooks.Add
     wb1.Sheets(1).Activate
    ActiveSheet.Paste
    
    '~~> Change the file Name Here
    'wb1.SaveAs "\\adpsfs\Accounting\Bobby\MyFile.xls"
 
Call fitWidth

    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

Sub fitWidth()
'
' When the sheet is copied, the columns need to be fit to widest and cleaned up a little bit

    ActiveSheet.Cells.Select

ActiveSheet.Cells.EntireColumn.AutoFit
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    ActiveSheet.Range("A1:G1").Select
    
With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.499984740745262
        .PatternTintAndShade = 0
    End With
     
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
   
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
  
    
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    'MsgBox ("still working2")
    ActiveSheet.Range("a1").Select
End Sub

Open in new window

0
 
BBluAuthor Commented:
ABSOLUTELY PERFECT!  And I can learn a little, too, by both of your explanations.  Thank you both!
0
 
BBluAuthor Commented:
Thank you both very much.
0
 
BBluAuthor Commented:
Actually, one more tweak, if possible.  Once I select a cell inside the range, the background color changes.  That is correct.  If I switch to another cell within the range, the previous cell is cleared out and the newly selected cell is colored. That is correct, too.  But, if I then select a cell outside of the range, the cell I left (the last one selected) remains with the background color.  How would I clear that background, as well?
0
 
Ingeborg Hawighorst (Microsoft MVP / EE MVE)Microsoft MVP ExcelCommented:
Hello,

just move the line

    Range("t8:w13").Interior.ColorIndex = xlNone

up to sit before the IF


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Range("t8:w13").Interior.ColorIndex = xlNone
    If Not intersect(target, range("t8:w13")) is nothing then
       With target.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = vbRed
       End With
end if
end sub

Open in new window

0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.