I am looking for some code that will change the colour of a shape when a cell is clicked on.
Example the shape is S_IRL which is Ireland and is located in Cell B22.
What I would like to happen is that if Cell B22 then shape S_IRL changes from Blue to Red. Then if another cell with a country is clicked then the corresponding shape changes to red and the previous returns to it previous colour.
Any help would be greatly appreciated
You can add a new subroutine in the worksheet's code that will fire when the selection changes on the sheet:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim strShapeName As String 'Variable to hold the shape name
Dim shp As Shape 'Variable to hold a shape object
'Detect if the click was in range A:C
If Not Intersect(Target, Range("A:C")) Is Nothing Then
'Boom... set all the shapes to blue
For Each shp In Me.Shapes
If Left(shp.Name, 2) = "S_" Then shp.Fill.ForeColor.RGB = RGB(0, 0, 255)
Next shp
'Grab the shape name from Column A
strShapeName = Cells(Target.Row, 1).Value
'Set the color of the shape to red
Shapes(strShapeName).Fill.ForeColor.RGB = RGB(255, 0, 0)
End If
End Sub
This will detect if the selection change was to a cell in columns A, B, or C. If it was it will grab the name of the shape from Column A and then set the color of that shape to red.
Related
I am currently trying to change Cells across several worksheets in a Workbook which have a specific colour to No Fill. Here is the code I am using below. Can anyone help?
Sub YellowFillToNoFill()
'RGB(246, 244, 150) Yellow Colour To change to no Fill
'PURPOSE: Change any cell with a Yellow fill color to a No fill color
Dim cell As Range
'Optimize Code
Application.ScreenUpdating = False
'Ensure Cell Range Is Selected
If TypeName(Selection) <> "Range" Then
MsgBox "Please select some cells before running"
Exit Sub
End If
'Loop Through Each Cell
For Each cell In ActiveSheet.UsedRange 'Can also use Range("C1,C2" etc.) instead of
'Selection.Cells' or 'ActiveSheet.UsedRange'
If cell.Interior.Color = RGB(246, 244, 150) Then
cell.Interior.Color = xlNone
End If
Next
End Sub
To reset the value, use Use cell.Interior.ColorIndex = xlNone
Color defines the color that is displayed. It's a long value that contains the RGB-value of the color.
ColorIndex is the index into the table of predefined colors (the table of colors you see when you select a color in Excel). The special value xlNone (-4142) removes any color setting.
I have a value in the cell V6 and i want it to change its color if the color of a specific sheet tab called "Test" is red (vbRed). I have tried a code but it doesn't seem to change the color of the text in the cell. I was wondering what is wrong and what could be done to fix it.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Test")
If ws.Tab.ColorIndex = vbRed Then
Range("v6").Font.Color = vbRed
End If
End Sub
One way to do this is to use a Boolean variable (I called my variable colortest) to test if the tab color is equal to vbRed or not.
this sample code turns the font color red if the tab is vbRed, and turns the font color black if the tab is any other color than vbRed.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ws As Worksheet, colortest As Boolean
Set ws = ThisWorkbook.Sheets("Test")
colortest = Sheets("Test").Tab.Color = vbRed
If colortest = True Then
Range("v6").Font.Color = vbRed
ElseIf colortest = False Then
Range("v6").Font.Color = vbBlack
End If
End Sub
`
Note: I used Worksheet_SelectionChange so the code runs as soon as you click out of cell vs having to edit a cell as in Worksheet_Change
My code to strike through blue colored visible rows after filtering a table isn't working as expected
Public Sub EditRows()
Dim rng As Range
Dim cell As Range
Dim Database As Worksheet
Set Database = ThisWorkbook.Worksheets(1)
Set rng = Database.AutoFilter.Range
Set rng = rng.Offset(1, 0).Resize(rng.Rows.count - 1, 1)
'Loop Through each visible row after filtering
For Each cell In rng.Columns(9).Cells.SpecialCells(xlCellTypeVisible)
'Strike through entire row if row is either these two shades of blue
If cell.Interior.Color = RGB(0, 112, 192) Or cell.Interior.Color = vbBlue Then
cell.Rows(rng).Font.Strikethrough = True
End If
Next cell
End Sub
Edit: Sorry for the confusion, the IF condition was based on the font color of that column instead of the interior color.
For Each cell In rng.Columns(9).Cells.SpecialCells(xlCellTypeVisible)
If cell.Font.Color = vbBlue Then
cell.EntireRow.Font.Strikethrough = True
End If
Next cell
4 things:
(1) First thing you need to check is if your code is dealing with the correct range of data. Check if the variable rng contains the range you are expecting, eg by putting a statement Debug.Print rng.address after the assignment. If that is okay, check if the loop if using the cells you are expecting, for example by putting a Debug.Print cell.addess inside the loop.
(2) If you are sure the loop handles the cells you are interested in, check if the blue you are checking is the correct blue. Set a breakpoint to your if-statement, execute the loop until a cell is hit that is blue (check the address) and check the interior-color in the debugger. vbBlue is 16711680 (&HFF0000), your manually defined blue color is 12611584 (&HC07000). If the color matches, it should enter the If-statement.
(3) If the cells are blue because of conditional formatting, check cell.DisplayFormat.Color rather than cell.Interior.Color
(4) I assume that you want to strikethrough the cell having blue color, so the statement should be simply cell.Font.Strikethrough = True.
I have a spreadsheet in excel where there are three types of cell. Black cells, yellow cells and cells with no fill. I am trying to write code so that the black cells will contain value 1, the yellow cells value 2 and the no fill cells value 0.
So far, this is what I have for the black and yellow cells:
Sub changeValuesBasedOnColour()
Dim rg As Range
Dim xRg As Range
Set xRg = Selection.Cells
Application.DisplayAlerts = False
For Each rg In xRg
With rg
Select Case .Interior.Color
Case Is = 0 'Black
.Value = 1
Case Is = 255255 'Yellow
.Value = 2
End Select
End With
Next
Application.DisplayAlerts = False
End Sub
This has worked for the cells in my spreadsheet which are filled black: they all now contain the value 1. However, nothing has changed for my cells filled yellow.
I thought that it could be to do with the wrong HEX code, but I have tried 2552550 and ```255255000`` as well. The yellow cells are filled with the yellow from the excel standard colors, as seen below.
You've got the wrong value for yellow; it should be 65535. That can be verified in several ways:
Selecting a yellow-colored cell and entering ? ActiveCell.Interior.Color in the Immediate Window and pressing Enter.
Entering ? vbYellow in the Immediate Window and pressing Enter.
Entering ? RGB(255, 255, 0) in the Immediate Window and pressing Enter.
In your code, you can just use vbBlack and vbYellow instead of 0 and 65535 respectively.
The colours must be specified exactly. Yellow <> Yellow. There are a thousand shade of yellow. The first instance of Application.DisplayAlerts = False in your code is unnecessary. The second one is a mistake.
The code below takes an approach opposite to the one you started out with. It reads the colour set and applies an index number if it's a "known" colour. The advantage of this system is that it's much easier to maintain and expand.
Sub SetValuesBasedOnColour()
Dim Cols As Variant ' array of colours
Dim Idx As Long ' index of Cols
Dim Cell As Range ' loop object
Cols = Array(vbBlack, vbYellow)
For Each Cell In Selection.Cells
With Cell
On Error Resume Next
Idx = WorksheetFunction.Match(.Interior.Color, Cols, 0)
If Err.Number = 0 Then .Value = Idx
End With
Next Cell
End Sub
I'm trying to get a cell to show the height of a shape after the shape height changes when dragging the shape handle. I can successfully do this with an event handler but that requires deselecting the shape. Is it possible to show the new height of the shape in a cell without deselecting the shape? Thanks in advance.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim heightVar As Integer
heightVar = Sheets("Sheet1").Shapes.Range(Array("boxbox1")).Height
Sheets("Sheet1").Range("B1") = heightVar
End Sub
I place a TextBox on my sheet. I make sure cells A1 and A2 are empty. I run the following macro:
Sub dural()
Dim s As Shape
Set s = ActiveSheet.Shapes("TextBox 1")
While Range("A1") = ""
Range("A2") = s.Height
DoEvents
Wend
End Sub
If you select the Shape and change its height, cell A2 will respond.
To stop the macro from looping, just put something in cell A1.