Interior Color Index question

I

ipbr21054

Well-known Member
Joined
Nov 16, 2010
Messages
5,226
Office Version
  1. 2007
Platform
  1. Windows
Hi,

The cells in my sheet are all yellow,apart from the active row which is blue interior color index 8
Because of the code below D21 never changes blue at Row 21

Please could you advise how i can add .Interior.ColorIndex = 8 to the existing code so when the code is executed at cell D21 it also changes it blue to match the rest in that row.



I have the code in use below.


Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim myStartCol As String
    Dim myEndCol As String
    Dim myStartRow As Long
    Dim myLastRow As Long
    Dim myRange As Range


    If Target.Cells.Count > 1 Then Exit Sub
    
    Application.ScreenUpdating = False
    
'   *** Specify columns to apply this to ***
    myStartCol = "A"
    myEndCol = "G"


'   *** Specify start row ***
    myStartRow = 21
    
'   Use first column to find the last row
    myLastRow = Cells(Rows.Count, myStartCol).End(xlUp).Row
    
'   Build range to apply this to
    Set myRange = Range(Cells(myStartRow, myStartCol), Cells(myLastRow, myEndCol))
    
'   Clear the color of all the cells in range
    myRange.Interior.ColorIndex = 6
    
'   Check to see if cell selected is outside of range
    If Intersect(Target, myRange) Is Nothing Then Exit Sub
    
'   Highlight the row and column that contain the active cell
    Range(Cells(Target.Row, myStartCol), Cells(Target.Row, myEndCol)).Interior.ColorIndex = 8
Target.Interior.Color = vbGreen
    Application.ScreenUpdating = True


Select Case Mid(Range("A21").Value, 10, 1)
Case Is = "X"
        Range("D21").Value = "1999"
Case Is = "Y"
        Range("D21").Value = "2000"
Case Is = "1"
        Range("D21").Value = "2001"
Case Is = "2"
        Range("D21").Value = "2002"
Case Is = "3"
        Range("D21").Value = "2003"
Case Is = "4"
        Range("D21").Value = "2004"
Case Is = "5"
        Range("D21").Value = "2005"
Case Is = "6"
        Range("D21").Value = "2006"
Case Is = "7"
        Range("D21").Value = "2007"
Case Is = "8"
        Range("D21").Value = "2008"
Case Is = "9"
        Range("D21").Value = "2009"
Case Is = "A"
        Range("D21").Value = "2010"
Case Is = "B"
        Range("D21").Value = "2011"
Case Is = "C"
        Range("D21").Value = "2012"
Case Is = "D"
        Range("D21").Value = "2013"
Case Is = "E"
        Range("D21").Value = "2014"
Case Is = "F"
        Range("D21").Value = "2015"
Case Is = "G"
        Range("D21").Value = "2016"
Case Is = "H"
        Range("D21").Value = "2017"
Case Is = "J"
        Range("D21").Value = "2018"
Case Is = "K"
        Range("D21").Value = "2019"
End Select


End Sub
 

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
Sort by date Sort by votes
If I understood correctly, you want row 21 to be blue, now it turns green, if so, simply remove this line from your code

Code: 
Target.Interior.Color = vbGreen
 
Upvote 0
Hi,
NO

The cells are all yellow.
When i click a cell that active row become cyan

When the code runs cell D21 is always yellow,i need it to also follow suit in that it is cyan when active row BUT yellow when un-active row

Thanks
 
Upvote 0
Try this, add this line: Range("D21").Interior.ColorIndex = 8


Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)


    Dim myStartCol As String
    Dim myEndCol As String
    Dim myStartRow As Long
    Dim myLastRow As Long
    Dim myRange As Range




    If Target.Cells.Count > 1 Then Exit Sub
    
    Application.ScreenUpdating = False
    
'   *** Specify columns to apply this to ***
    myStartCol = "A"
    myEndCol = "G"


'   *** Specify start row ***
    myStartRow = 21
    
'   Use first column to find the last row
    myLastRow = Cells(Rows.Count, myStartCol).End(xlUp).Row
    
'   Build range to apply this to
    Set myRange = Range(Cells(myStartRow, myStartCol), Cells(myLastRow, myEndCol))
    
'   Clear the color of all the cells in range
    myRange.Interior.ColorIndex = 6
    
'   Check to see if cell selected is outside of range
    If Intersect(Target, myRange) Is Nothing Then Exit Sub
    
'   Highlight the row and column that contain the active cell
    Range(Cells(Target.Row, myStartCol), Cells(Target.Row, myEndCol)).Interior.ColorIndex = 8
[COLOR=#0000ff]    Range("D21").Interior.ColorIndex = 8[/COLOR]
    Target.Interior.Color = vbGreen
    Application.ScreenUpdating = True




Select Case Mid(Range("A21").Value, 10, 1)
Case Is = "X"
        Range("D21").Value = "1999"
Case Is = "Y"
        Range("D21").Value = "2000"
Case Is = "1"
        Range("D21").Value = "2001"
Case Is = "2"
        Range("D21").Value = "2002"
Case Is = "3"
        Range("D21").Value = "2003"
Case Is = "4"
        Range("D21").Value = "2004"
Case Is = "5"
        Range("D21").Value = "2005"
Case Is = "6"
        Range("D21").Value = "2006"
Case Is = "7"
        Range("D21").Value = "2007"
Case Is = "8"
        Range("D21").Value = "2008"
Case Is = "9"
        Range("D21").Value = "2009"
Case Is = "A"
        Range("D21").Value = "2010"
Case Is = "B"
        Range("D21").Value = "2011"
Case Is = "C"
        Range("D21").Value = "2012"
Case Is = "D"
        Range("D21").Value = "2013"
Case Is = "E"
        Range("D21").Value = "2014"
Case Is = "F"
        Range("D21").Value = "2015"
Case Is = "G"
        Range("D21").Value = "2016"
Case Is = "H"
        Range("D21").Value = "2017"
Case Is = "J"
        Range("D21").Value = "2018"
Case Is = "K"
        Range("D21").Value = "2019"
End Select




End Sub
 
Upvote 0
Hi,
That only made it blue all the time.

I think we need to put the code AFTER & BEFORE

End Select


End Sub
 
Upvote 0
Let's follow up:
I select cell A21, what should happen to cell D21?
I select cell D21, what should happen to cell D21?
I select cell A22, what should happen to cell D21?
I select cell A5, what should happen to cell D21?
 
Upvote 0
HI,
I open the worksheet & all cells are yellow.

The range is A21:G21
When you click a cell that cell should be GREEN.
The other cells in that row should be BLUE.
The other cells on the sheet should be YELLOW

So example.
Select A26
A26 is GREEN
All other cells in Row 26 are BLUE.
All other cells on the sheet are YELLOW

Select F68
F68 is GREEN
All other cells in Row 68 are BLUE.
All other cells on the sheet are YELLOW

Select C116
C116 is GREEN
All other cells in Row 116 are BLUE.
All other cells on the sheet are YELLOW

Here is the problem.

Select A21 or B21 or C21 or E21 or F21 orG21
The selected cell is then GREEN cell D21 is YELLOW "it does not turn BLUE"
All other cells in Row 21 are BLUE.
All other cells on the sheet are YELLOW

Cell D21 is only ever shown as YELLOW

Cell D21 should be GREEN if selected

Cell D21 should be BLUE if another cell in Row 21 is selected.

Cell D21 should be YELLOW when another cell on the worksheet is selected

 
Upvote 0
ipbr21054 said:
Here is the problem.


Select A21 or B21 or C21 or E21 or F21 orG21
The selected cell is then GREEN cell D21 is YELLOW "it does not turn BLUE"
All other cells in Row 21 are BLUE.
All other cells on the sheet are YELLOW


Cell D21 is only ever shown as YELLOW

Cell D21 should be GREEN if selected

Cell D21 should be BLUE if another cell in Row 21 is selected.

Cell D21 should be YELLOW when another cell on the worksheet is selected
Click to expand...



That's my confusion, because in the tests with your code when I select A21, B21, C21, E21, F21, cell D21 is blue, and when I select D21 the cell turns green; and when I select any other cell, D21 is yellow.
Do you have any conditional format on the sheet?
 
Upvote 0
Hi,
There is no conditional formatting.

I will take a closer look and reply soon,thank
 
Upvote 0
Here is the full code on that sheet.

Code: 
Private Sub NewRowButton_Click()With Sheets("HONDA SHEET")
    .Range("A21").EntireRow.Insert Shift:=xlDown
    .Range("A21:G21").Borders.Weight = xlThin
    .Range("G21").Value = Date
    .Range("A13").Interior.ColorIndex = 2
     Range("C1:F21").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    Range("A13").Interior.ColorIndex = 6
    End With
End Sub


Private Sub CheckButton_Click()
HondaParts.Show
End Sub
Sub OpenFile()
Workbooks.Open Filename:="C:\LEADERBOARD\book.xls"
End Sub




Private Sub BalanceSoFar_Click()
    Dim lngLastRow          As Long
    Dim lngSumValues        As Double
    
    With Sheets("DATABASE")
        lngLastRow = .Cells(.Rows.Count, "O").End(xlUp).Row
        lngSumValue = Application.WorksheetFunction.Sum(.Range("O5:O" & lngLastRow))
    End With
    
    MsgBox "Earnings To Date " & Format(lngSumValue, "£0.00")




End Sub


Private Sub OnlineEpc_Click()
ActiveWorkbook.FollowHyperlink Address:="https://honda-europe.epc-data.com/", NewWindow:=True
End Sub


Private Sub EpcLate_Click()
ActiveWorkbook.FollowHyperlink Address:="http://www.hondapartsdeals.com/honda_parts.php", NewWindow:=True
End Sub




Private Sub ComboBox1_Change()


End Sub


Private Sub EuropeEpc_Click()
ActiveWorkbook.FollowHyperlink Address:="https://honda-europe.epc-data.com/", NewWindow:=True
End Sub


Private Sub Hondasheet_bluecells_Click()
    Range("C1:F17").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    Range("A13").Select
End Sub


Private Sub Hondasheet_leaderboard_Click()


    Worksheets("HONDA SHEET").Range("C1:D17").Copy Worksheets("SOLD ITEMS").Range("C2:D19")
    Worksheets("HONDA SHEET").Range("E1:F17").Copy Worksheets("SOLD ITEMS").Range("C19:D35")
    
    ActiveWorkbook.Worksheets("SOLD ITEMS").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("SOLD ITEMS").Sort.SortFields.Add Key:=Range("D2"), _
    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
    xlSortTextAsNumbers
    With Worksheets("SOLD ITEMS").Sort
        .SetRange Range("C2:D35")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        Range("A16").Select
        .Apply
        
        End With
    Application.CutCopyMode = False
    Call HONDA_SALES_TABLE
    
    End Sub


Private Sub Hondasheet_zerocells_Click()
    Dim warning
    warning = MsgBox(Range("A3").Value & "Are You Sure You Wish To Zero All The Cells ?", vbQuestion + vbYesNo, "Warning This Will Delete The Cell Info")
    If warning = vbNo Then Exit Sub
    
    
    Range("D1", "D17") = "0"
    Range("F1", "F17") = "0"
    Range("C1:F17").Select
        With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
        End With
    Range("A13").Select
End Sub
Private Sub JapanEpc_Click()
ActiveWorkbook.FollowHyperlink Address:="https://honda.epc-data.com/", NewWindow:=True
End Sub


Private Sub LateEpc_Click()
ActiveWorkbook.FollowHyperlink Address:="http://www.hondapartsdeals.com/honda_parts.php", NewWindow:=True
End Sub


Private Sub PoundSign_Click()
    Dim lngLastRow          As Long
    Dim lngSumValues        As Double
    
    With Sheets("DATABASE")
        lngLastRow = .Cells(.Rows.Count, "O").End(xlUp).Row
        lngSumValue = Application.WorksheetFunction.Sum(.Range("O5:O" & lngLastRow))
    End With
    
    MsgBox "Earnings To Date " & Format(lngSumValue, "£0.00")




End Sub


Private Sub TopOfPage_Click()
Range("A21").Select
End Sub


Private Sub VinToolButton_Click()
ActiveWorkbook.FollowHyperlink Address:="http://www.hondapartsdeals.com/honda_parts.php", NewWindow:=True
End Sub


Private Sub Worksheet_Activate()
    Range("A13").Select
    Range("A13").Font.Size = 18
    Range("A13").BorderAround xlContinuous, xlThin
    Range("A17").BorderAround xlContinuous, xlThin
    ActiveWindow.ScrollRow = 14
    Range("A17").Interior.ColorIndex = 2
    Range("A17").Font.Size = 18
    Range("A17").Name = "Calibri"


End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Frng As Range
Set Frng = Range("F21", Range("F" & Rows.Count).End(xlUp))
If Target.Address(0, 0) = "A2" Then
    With HondaSoldItems
        .Caption = "HONDA SOLD ITEMS TABLE"
        .txtQuantitySold.Text = Application.CountIf(Frng, Target.Value)
        .txtSoldItems.Text = Target.Value
        .CommandButton1.SetFocus
        .Show
        End With
End If
With ThisWorkbook.Sheets("HONDA SHEET")
If Not Intersect(Target, .Range("A13")) Is Nothing And .Range("A13") <> "" Then
If Len(.Range("A13").Value) <> 17 And Len(.Range("A13").Value) <> 11 Then
                .Range("A13").Interior.ColorIndex = 3
                 MsgBox "Honda Japan Use 11 Character Vin Numbers." & vbNewLine & "" & vbNewLine & "Honda Europe Use 17 Character Vin Numbers." & vbNewLine & "" & vbNewLine & "Please Check & Try Again", vbCritical, "Chassis Number Wrong Character Count"
                .Range("A13").ClearContents
                .Range("A13").Interior.ColorIndex = 2
                .Range("A13").Activate
Else
                Application.EnableEvents = False
                .Rows(21).Insert Shift:=xlDown
                .Range("A21:G21").Borders.Weight = xlThin
                .Range("G21").Value = Date
                .Range("A21").Value = UCase(.Range("A13").Value)
                .Range("B21").Select
                .Range("A13").ClearContents
                .Range("A21").Characters(Start:=10, Length:=1).Font.ColorIndex = 3
                Application.EnableEvents = True
End If
End If


End With


Target.Interior.ColorIndex = 6
If Not Intersect(Target, Range("F21")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
If Target.Value = "ACCORD ID 48" Then Range("D1").Value = Range("D1").Value + 1
If Target.Value = "ACCORD ID 8E" Then Range("D2").Value = Range("D2").Value + 1
If Target.Value = "BLACK NRK ID 46" Then Range("D3").Value = Range("D3").Value + 1
If Target.Value = "BLACK NRK ID 48" Then Range("D4").Value = Range("D4").Value + 1
If Target.Value = "BLACK NRK ID 8E" Then Range("D5").Value = Range("D5").Value + 1
If Target.Value = "CIVIC CE0523" Then Range("D6").Value = Range("D6").Value + 1
If Target.Value = "CRV HLIK-1T" Then Range("D7").Value = Range("D7").Value + 1
If Target.Value = "CRV ID 48" Then Range("D8").Value = Range("D8").Value + 1
If Target.Value = "FLIP HLIK-1T 2B" Then Range("D9").Value = Range("D9").Value + 1
If Target.Value = "FLIP HLIK-1T 3B" Then Range("D10").Value = Range("D10").Value + 1
If Target.Value = "FRV ID 48" Then Range("D11").Value = Range("D11").Value + 1
If Target.Value = "FRV ID 8E" Then Range("D12").Value = Range("D12").Value + 1
If Target.Value = "G8D-345H-A" Then Range("D13").Value = Range("D13").Value + 1
If Target.Value = "G8D-348H-A" Then Range("D14").Value = Range("D14").Value + 1
If Target.Value = "G8D-350H-A" Then Range("D15").Value = Range("D15").Value + 1
If Target.Value = "G8D-453H-A" Then Range("D16").Value = Range("D16").Value + 1
If Target.Value = "G8D-456H-A" Then Range("D17").Value = Range("D17").Value + 1
If Target.Value = "HONDA 001" Then Range("F1").Value = Range("F1").Value + 1
If Target.Value = "HONDA 022" Then Range("F2").Value = Range("F2").Value + 1
If Target.Value = "HONDA 023" Then Range("F3").Value = Range("F3").Value + 1
If Target.Value = "HONDA 024" Then Range("F4").Value = Range("F4").Value + 1
If Target.Value = "HONDA 036" Then Range("F5").Value = Range("F5").Value + 1
If Target.Value = "HONDA 042" Then Range("F6").Value = Range("F6").Value + 1
If Target.Value = "HON 58 ID 13" Then Range("F7").Value = Range("F7").Value + 1
If Target.Value = "HON 58 ID 48" Then Range("F8").Value = Range("F8").Value + 1
If Target.Value = "JAZZ HLIK-1T" Then Range("F9").Value = Range("F9").Value + 1
If Target.Value = "JAZZ ID 48" Then Range("F10").Value = Range("F10").Value + 1
If Target.Value = "JAZZ ID 8E" Then Range("F11").Value = Range("F11").Value + 1
If Target.Value = "KEY DIY NBXTT ID 47" Then Range("F12").Value = Range("F12").Value + 1
If Target.Value = "LEGEND ID 8E" Then Range("F13").Value = Range("F13").Value + 1
If Target.Value = "SILVER NRK ID 48" Then Range("F14").Value = Range("F14").Value + 1
If Target.Value = "SILVER NRK ID 8E" Then Range("F15").Value = Range("F15").Value + 1
If Target.Value = "72147-S2H-G01" Then Range("F16").Value = Range("F16").Value + 1
If Target.Value = "S2000 CAT 1" Then Range("F17").Value = Range("F17").Value + 1
End If
    If Target.Address = "$F$21" Then
        Call sheettolist




End If
Application.EnableEvents = True
End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)


    Dim myStartCol As String
    Dim myEndCol As String
    Dim myStartRow As Long
    Dim myLastRow As Long
    Dim myRange As Range


    If Target.Cells.Count > 1 Then Exit Sub
    
    Application.ScreenUpdating = False
    
'   *** Specify columns to apply this to ***
    myStartCol = "A"
    myEndCol = "G"


'   *** Specify start row ***
    myStartRow = 21
    
'   Use first column to find the last row
    myLastRow = Cells(Rows.Count, myStartCol).End(xlUp).Row
    
'   Build range to apply this to
    Set myRange = Range(Cells(myStartRow, myStartCol), Cells(myLastRow, myEndCol))
    
'   Clear the color of all the cells in range
    myRange.Interior.ColorIndex = 6
    
'   Check to see if cell selected is outside of range
    If Intersect(Target, myRange) Is Nothing Then Exit Sub
    
'   Highlight the row and column that contain the active cell
    Range(Cells(Target.Row, myStartCol), Cells(Target.Row, myEndCol)).Interior.ColorIndex = 8
    Target.Interior.Color = vbGreen
    Application.ScreenUpdating = True


Select Case Mid(Range("A21").Value, 10, 1)
Case Is = "X"
        Range("D21").Value = "1999"
Case Is = "Y"
        Range("D21").Value = "2000"
Case Is = "1"
        Range("D21").Value = "2001"
Case Is = "2"
        Range("D21").Value = "2002"
Case Is = "3"
        Range("D21").Value = "2003"
Case Is = "4"
        Range("D21").Value = "2004"
Case Is = "5"
        Range("D21").Value = "2005"
Case Is = "6"
        Range("D21").Value = "2006"
Case Is = "7"
        Range("D21").Value = "2007"
Case Is = "8"
        Range("D21").Value = "2008"
Case Is = "9"
        Range("D21").Value = "2009"
Case Is = "A"
        Range("D21").Value = "2010"
Case Is = "B"
        Range("D21").Value = "2011"
Case Is = "C"
        Range("D21").Value = "2012"
Case Is = "D"
        Range("D21").Value = "2013"
Case Is = "E"
        Range("D21").Value = "2014"
Case Is = "F"
        Range("D21").Value = "2015"
Case Is = "G"
        Range("D21").Value = "2016"
Case Is = "H"
        Range("D21").Value = "2017"
Case Is = "J"
        Range("D21").Value = "2018"
Case Is = "K"
        Range("D21").Value = "2019"
End Select


End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Solved
Code to apply only to my table range
Replies
3
Views
351
Alex Blakenburg
A
I
  • Question
Ignore the error message & dont show me the RTE message
Replies
6
Views
391
ipbr21054
I
E
  • Question
Help Cleaning Up / Optimizing VBA Code
Replies
6
Views
283
offthelip
O
M
  • Question
Hide Rows based on cell with drop down values
Replies
1
Views
420
kevin9999
K
I
  • Solved
Selceting a cell will then highlite the row in range
Replies
3
Views
351
mohadin
M

Forum statistics

Threads
1,214,932
Messages
6,122,332
Members
449,077
Latest member
jmsotelo

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top