I have these sheets Sheet1 and another which is Sheet2.
Sheet1 gets its values (including color of the cell) from Sheet2.
I have this block of code to check for the active cell color in Sheet2 and then change the color of the same cell in Sheet1.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Interior.Color = 5296274 Then
Worksheets("ALL BRANDS").Range(Target.Address(False, False)).Interior.Color = 5296274
Else
Worksheets("ALL BRANDS").Range(Target.Address(False, False)).Interior.Color = ActiveSheet.Range(Target.Address(False, False)).Interior.Color
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Interior.Color = 5296274 Then
Worksheets("ALL BRANDS").Range(Target.Address(False, False)).Interior.Color = 5296274
Else
Worksheets("ALL BRANDS").Range(Target.Address(False, False)).Interior.Color = ActiveSheet.Range(Target.Address(False, False)).Interior.Color
End If
End Sub
The problem is when I select multiple cells at a time in Sheet2
it colors the referenced cell in Sheet1 to
You need to collect the Interior.Color property of each cell individually.
When a Range object consists of multiple cells, a few properties (like Value and Formula) will return an array of values. Many properties, including Interior.Color, will not. In the case of Interior.Color, if ALL the cells in the range have the same background color, you will get the correct value. If even one cell has a different color, the property cannot give you a single correct answer, and simply returns 0 (black).
As a side note, your If statement isn't doing anything useful as written. I'll assume you want to copy any occurring color for the sample below. If you only want to copy that certain shade of green, keep your If but drop the Else.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
With Worksheets("ALL BRANDS")
For Each c In Target
.Range(c.Address).Interior.Color = c.Interior.Color
Next c
End With
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c As Range
With Worksheets("ALL BRANDS")
For Each c In Target
.Range(c.Address).Interior.Color = c.Interior.Color
Next c
End With
End Sub
Really, you should move that code into a function and call it from each event instead of rewriting and maintaining the code in multiple places.
Related
I have written a macro to color my cells green if the input is TRUE and red if the input to cell is FALSE.
Private Sub Worksheet_Change(ByVal Target As Range)
If ActiveSheet.Name = "Ribs" Then
If Not Intersect(Target, Range("G2:K200")) Is Nothing Then
If Target = "False" Then
Sheets("Ribs").Range(Target.Address).Style = "Bad"
ElseIf IsNumeric(Target) Then
Sheets("Ribs").Range(Target.Address).Style = "Good"
End If
ElseIf Not Intersect(Target, Range("D2:D200")) Is Nothing Then
RotateRib (Target.Address)
End If
End If
End Sub
Now the problem is that if I change the range value (for example typing TRUE in cell G2 and than drag mouse pointer from bottom right corner of G2 to G10 should copy value TRUE to range G2:G10) raises Type Mismatch error in my macro.
Debugger says the problematic line is If Target = "False" Then.
Is there a workaround the given error? Ignoring the error would probably do the job, but it's not something I'd like to do.
The problem is that you're trying to do an illegal operation. You're asking the compiler to see if the contents of G2:G10 is equal to False - you can see this by adding Debug.Print Target.Address to the top of your code and then making another attempt.
It is possible to do what you want, but you'll need more code. When comparing values, you have to do it cell by cell - you can't compare an entire range at once. Here's a rudimentary example:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
If ActiveSheet.Name = "Ribs" Then
For Each c In Target
If Not Intersect(c, Range("G2:K200")) Is Nothing Then
If c.Value = "False" Then
Sheets("Ribs").Range(c.Address).Style = "Bad"
ElseIf IsNumeric(c.Value) Then
Sheets("Ribs").Range(c.Address).Style = "Good"
End If
ElseIf Not Intersect(c, Range("D2:D200")) Is Nothing Then
RotateRib (c.Address)
End If
Next c
End If
End Sub
The principal change is that we're no longer comparing against Target, we're looping through all the individual cell contents (Range objects denoted as c) of Target and comparing against those.
Again, you can verify that this works by trying this code and filling down some values:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
For Each c In Target
Debug.Print c.Address
Next c
End Sub
There's absolutely no need to check the name of active sheet, since Worksheet_Change event fires on the sheet where it's defined.
Rather iterating over each cell in the Target, you could receive the intersection and apply your settings directly.
Don't forget about that Target can contain non-contiguous ranges (accessed by Areas property). My code handles this situation, but can't say the same about RotateRib.
To sum up:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngIntersect As Range, rngArea As Range, cell As Range
Set rngIntersect = Intersect(Target, Range("G2:K200"))
If Not rngIntersect Is Nothing Then
For Each rngArea In rngIntersect.Areas
For Each cell In rngArea
cell.Style = IIf(cell, "Good", "Bad")
Next
Next
End If
Set rngIntersect = Intersect(Target, Range("D2:D200"))
If Not rngIntersect Is Nothing Then RotateRib (rngIntersect)
End Sub
I have a table called Table1
In Column B, I have the ticket number. e.g: 76537434
Requirement: when any change happens in any cell in column B, that cell (Target cell) to be changed into a hyperlink such that the hyperlink address would be example.com/id=76537434
Cell value i.e. 76537434 must remain the same
Add this event handler to your worksheet's code module:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 2 Then Exit Sub
Target.Hyperlinks.Delete ' or Target.ClearHyperlinks to conserve the formatting
Me.Hyperlinks.Add Target, "http://example.com/id=" & Target.value
End Sub
The following Worksheet_Change event should be able to solve your problem:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim tmp As String
If Intersect(Range("B:B"), Target) Is Nothing Then Exit Sub
For Each cell In Target
If cell.Column = 2 Then
Application.EnableEvents = False
tmp = cell.Value2
cell.Parent.Hyperlinks.Add _
Anchor:=Cells(cell.Row, 2), _
Address:="http://example.com/id=" & tmp, _
TextToDisplay:=tmp
Application.EnableEvents = True
End If
Next cell
End Sub
Note, that you must copy it to the sheet and not into a separate module.
=HYPERLINK(E14&F14,"Name")
where cell E14 contains "http://www.example.com/id=" and cell F14 contains "76537434".
This soultions doesn't need VBA macros.
How can I set up vba code to allow user to type in several selections and then the accompanying list filters based on that input, reference cell? I tried this but its only filtering the first selection.
I set it up as a worksheet script, so it only runs on that one sheet and set it up to only run when the user input cells (A1, A2) are updated.
I then tried getting the lists in columns C:D to filter, based on the values in A1 and A2.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'This line stops the worksheet updating on every change, it only updates when cell is touched
If Intersect(Target, Range("A1:B5")) Is Nothing Then Exit Sub
With Sheets("TestTab")
.Range("C1:D100").AutoFilter Field:=1, Criteria1:=.Range("A1").Value, Field:=2, Criteria1:=.Range("A2").Value
End With
End Sub
If you are trying to filter a single column with what is in either cell A1 or A2:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'This line stops the worksheet updating on every change, it only updates when cell is touched
If Intersect(Target, Range("A1:A2")) Is Nothing Then Exit Sub
With Sheets("TestTab")
.Range("C3:D100").AutoFilter Field:=1, Criteria1:=.Range("A1").Value, Operator:=xlOr, Criteria2:=.Range("A2").Value
End With
End Sub
If you are trying to filter column C on A1 and column D on A2:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'This line stops the worksheet updating on every change, it only updates when cell is touched
If Intersect(Target, Range("A1:A2")) Is Nothing Then Exit Sub
With Sheets("Sheet1")
.Range("C1:D100").AutoFilter Field:=1, Criteria1:=.Range("A1").Value
.Range("C1:D100").AutoFilter Field:=2, Criteria1:=.Range("A2").Value
End With
End Sub
I have data in column "AK" and a button in Column "AL"; there are several hundred rows and there is only one macro for all buttons as it uses relative references based on the row it is in.
I want the button to only be visible when there is data in the adjacent cell. The following pseudo-code explains what I am trying to achieve:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 37 Then
If Target.Value = 0 Then
Shapes(Target.offset(0, 1)).Visible = False
Else
Shapes(Target.offset(0, 1)).Visible = True
End If
End If
End Sub
The reason for doing this is that the value in AK is calculated based on other values and only displays once all mandatory fields have been completed. The button should only be available for an automation task once all details are complete. What real code would make this work without having to call each button out individually?
I'm not sure if you can directly reference a shape by its location on the sheet.
This code will look at each shape until it finds the one to the right of the cell you've just changed, it will then change the visibility based on the contents of the cell.
(Target.Value <> "") returns TRUE/FALSE.
This will only work if your buttons are placed in the correct cell (slightly too high and it will return the cell above).
Private Sub Worksheet_Change(ByVal Target As Range)
Dim shp As Shape
For Each shp In ThisWorkbook.Worksheets("Sheet1").Shapes
If shp.TopLeftCell.Address = Target.Offset(, 1).Address Then
shp.Visible = (Target.Value <> "")
Exit For 'Exit the loop - the correct button has been found.
End If
Next shp
End Sub
Edit:
I've updated the code so it checks that only a single cell has been changed and then looks at each dependent cell of the cell that was changed.
This will probably muck up if the dependent cell is on another sheet though.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rUpdated As Range
Dim shp As Shape
Dim rCell As Range
If Target.Cells.Count = 1 Then
'Hopefully someone will have better code than On Error....
On Error Resume Next
Set rUpdated = Range(Target.Dependents.Address)
On Error GoTo 0
If Not rUpdated Is Nothing Then
'Look at each dependent cell in rUpdated.
For Each rCell In rUpdated
'Look at each shape in the sheet and cross-reference with rCell.
For Each shp In Target.Parent.Shapes
If shp.TopLeftCell.Address = rCell.Offset(, 1).Address Then
shp.Visible = (Target.Value = 0)
Exit For 'Exit the loop - the correct button has been found.
End If
Next shp
Next rCell
End If
End If
End Sub
NB: I got the idea for checking the dependent cell from here: How can I run a VBA code each time a cell get is value changed by a formula?
I'm trying to figure out a VBA code that will allow me to prefill a certain cell with a number when I type in "X" in a cell right next to it. I can't figure out if I should use Range, or Insert, or what.
I cannot use a button and assign a macro to it because I need to see which cells I have put an "X" into.
This is what I have so far, but it's using a button with macro assigned to it:
490 is being entered into E9 and tabs over to F9 after the macro button is clicked:
Sub eightNineSpring()
Range("E9").Select
ActiveCell.FormulaR1C1 = "490"
Range("F9").Select
End Sub
as automation put in the worksheet you need it:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 6 And Target.Count = 1 Then
If Target.Value = "x" Then Target.Offset(0, -1).Value = 490
End If
End Sub
or as formula in E1 then copy down
=IF(F1="x",490,"")
But keep in mind when deleting the "x" (or replace it with something different):
The function will empty the 490 again while the change event will not
When using a Change Events that makes a change, Application.Events should be turned off to avoid the code calling itself recursively.
The code below caters for one or more cells in E1:E10 being updated.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = Intersect(Target, Range("F1:F10"))
If rng1 Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each rng2 In Range
If rng2.Value = "x" Then rng2.Offset(0, -1).Value = 490
Next
Application.EnableEvents = True
End Sub