Solved

Color Selected (Single Click) Cell with a background color

Posted on 2011-03-02
10
341 Views
Last Modified: 2012-05-11

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?
0
Comment
Question by:BBlu
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 6
  • 2
  • 2
10 Comments
 
LVL 22

Assisted Solution

by:rspahitz
rspahitz earned 200 total points
ID: 35021982
   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
 

Author Comment

by:BBlu
ID: 35022043
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
 
LVL 22

Assisted Solution

by:rspahitz
rspahitz earned 200 total points
ID: 35022221
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
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:BBlu
ID: 35022433
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
 

Author Comment

by:BBlu
ID: 35042003
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
 
LVL 50

Accepted Solution

by:
Ingeborg Hawighorst (Microsoft MVP / EE MVE) earned 150 total points
ID: 35042019
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
 

Author Comment

by:BBlu
ID: 35042119
ABSOLUTELY PERFECT!  And I can learn a little, too, by both of your explanations.  Thank you both!
0
 

Author Closing Comment

by:BBlu
ID: 35042122
Thank you both very much.
0
 

Author Comment

by:BBlu
ID: 35042130
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
 
LVL 50
ID: 35042144
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

Featured Post

Enroll in May's Course of the Month

May’s Course of the Month is now available! Experts Exchange’s Premium Members and Team Accounts have access to a complimentary course each month as part of their membership—an extra way to increase training and boost professional development.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Introduction While answering a recent question (http:/Q_27311462.html), I created an alternative function to the Excel Concatenate() function that you might find useful.  I tested several solutions and share the results in this article as well as t…
This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
The viewer will learn how to use the =DISCRINV command to create a discrete random variable, use this command to model a set of probabilities and outcomes in a Monte Carlo simulation, and learn how to find the standard deviation of a set of probabil…
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…

732 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question