I have a table of customer data in Excel that can be added/edited using a VBA userform. Therefore I would like to highlight the row that has just been added/edited. This is my first time using VBA so I searched and found code from here:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Value <> "" Then
Target.Interior.ColorIndex = 6
End If
End Sub
which works perfectly fine but the highlights for the previous edits/add-ons are still there. I just want the last one to be highlighted.
Use a variable. Store the range in that when you are changing the color. Next time remove the color from that range.
Is this what you are trying?
Dim prevRng As Range
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim aCell As Range
If Not prevRng Is Nothing Then prevRng.Interior.ColorIndex = xlNone
Set prevRng = Target
For Each aCell In Target
If aCell.Value <> "" Then aCell.Interior.ColorIndex = 6
Next aCell
End Sub
This will handle multiple cells as #Pᴇʜ mentioned in the comment.
Here is some code that could work for you:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'Removing old conditional formatting if it exists already
Conditions = ActiveSheet.Cells.FormatConditions.Count
For i = 1 to Conditions
If ActiveSheet.Cells.FormatConditions(i).Type = 2 Then
If ActiveSheet.Cells.FormatConditions(i).Formula1 = "=1" Then ActiveSheet.Cells.FormatConditions(i).Delete
End If
Next i
'Adding new conditional formatting rule to the edited range
Target.EntireRow.FormatConditions.Add Type:=xlExpression, Formula1:="=1"
Target.EntireRow.FormatConditions(1).Interior.ColorIndex = 6
End Sub
Currently it will highlight all the last edited rows in all sheets. Not sure if this is what you wanted.
It will keep colored cells in your sheet intact when a new range has been changed.
It will keep other conditional formatting rules intact.
It highlights the last edited range, even if the range has been cleared!
Related
I need to highlight and entire row if a cell string contains the word "risk". But I need to make it using vba since the person using it will write on it after using the macro.
I have something like:
The reason will be written afterwards and I need to highlight the row if someone writes the word risk anywhere in this column. Anything can be written there.
I use this to highlite a row when I want a full match:
lastReg= Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = Range("A1:J" & lastReg)
Rng.FormatConditions.Add Type:=xlExpression, Formula1:="=$J1=""Plat"""
...
so I tried:
Rng.FormatConditions.Add Type:=xlExpression, Formula1:="=FIND(""risk"",$J1)>0"
But it doesn't work.
Edit: it gives me an execution error so the code itself doesn't run.
Edit2: Someone else uses this macro, and he can't do it by himself so I wanted the code to do it for him.
Also, the code is stored in the personal.xlsb because he runs the code in a different worksheet everyday, so I can't pre config the formatConditions for the worksheet.
I would use a worksheet change event. place this sub in your worksheet. Whenever any cell in column 5 changes and the value is "risk", it will color the row.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range
Set Rng = Columns(5)
If Not Intersect(Rng, Target) Is Nothing And Target.Value = "risk" Then
Target.Offset(, -4).Resize(, 5).Interior.Color = vbYellow
End If
End Sub
Try:
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim cell As Range
If Not Intersect(Target, Sh.UsedRange) Is Nothing Then
For Each cell In Target.Cells
With cell
If UCase(.Value) = "RISK" Then
.Font.Color = vbRed
Else
.Font.Color = vbBlack
End If
End With
Next cell
End If
End Sub
I'm trying to make hyperlinks in the first column on the condition that value in the cell begins with 'W'.
It seemed to work until I moved the script from Sheet object to ThisWorkbook.
Since then when I try to copy some cells from another worksheet and paste them to active worksheet, everything what I copied is pasted as hyperlink, no matter what column or value it is. What's more, if I try to type anything in the row where the first cell is linked, the default typing mode is in the hyperlink style.
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim KeyCells2 As Range
Set KeyCells2 = Range("A:A")
If Not Application.Intersect(KeyCells2, Range(Target.Address)) _
Is Nothing Then
On Error Resume Next
If Target.Count = 1 Then 'this one was meant to be a fix but it didn't change a thing
If Left(Target.Value, 1) = "W" Then
link = "http://<mylink>" & Target.Value
ActiveSheet.Hyperlinks.Add Target, link
End If
End If
End If
End Sub
Try this, I think it will do what you need:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim KeyCells2 As Range
Dim targetcell As Range
Set KeyCells2 = Application.Intersect(Sh.Range("A:A"), Target, Sh.UsedRange)
If Not KeyCells2 Is Nothing Then
For Each targetcell In KeyCells2
If Left(targetcell.Value, 1) = "W" Then
link = "http://my.link." & targetcell.Value
Sh.Hyperlinks.Add Anchor:=targetcell, Address:=link
End If
Next
End If
End Sub
What I'm trying to do is when a cell (A1) matches something in a named range ("Names") then it changes colour, however if it doesn't but matches something a different named range ("Eye") then it becomes a different colour (there are many more ranges, but I'm sure I'll be able to figure it out after I have two working)
Things to note:
I know this can be done with conditional formatting, however due to the number of named ranges, and sizes of the ranges I was hoping it would be easier using a macro.
I so far have managed to get it working for one named range, and when A1 isn't a formula (however A1 will be)
My 2 lots of code so far are (note this is under sheet1):
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Application.Run ("Colour")
End If
End Sub
The my second one (is being a seperate module):
Sub Colour()
With ActiveSheet
For Each c In .Range("Names").Cells
If c.Value = .Range("A1").Value Then
Range("A1").Select
With Selection.Interior
.Color = 5287936
End With
End If
Next c
End With
End Sub
I think this does what you want:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("A1")) Is Nothing Then
ApplyColor Me.Range("A1")
End If
End Sub
Sub ApplyColor(ValueRange As Range)
Dim MatchRanges As Variant
Dim MatchColors As Variant
Dim MatchValue As Variant
Dim i As Long
MatchRanges = Array("Names", "Eye")
MatchColors = Array(5287936, 4287952)
MatchValue = ValueRange.Value
ValueRange.Interior.Color = vbWhite
For i = LBound(MatchRanges) To UBound(MatchRanges)
If WorksheetFunction.CountIf(Me.Range(MatchRanges(i)), MatchValue) > 0 Then
ValueRange.Interior.Color = MatchColors(i)
Exit For
End If
Next i
End Sub
A couple of notes: "Color" is a VBA reserved word and could cause issues, so I used something else for your sub name. You don't need to use Application.Run in this situation, just the sub's name and its arguments (or Call if you prefer).
I try to write a macro that on double click of a cell, inserts a new row below that cell with some formulas. The important thing for me is that if I double click the cell again, then the formulas of the previously inserted line are updated with the right indexes.
For example, in the code below, double click A1 will insert the formula =B2+1 in line 2. Double clicking again should insert the same in line 2. But now line 2 shifter to line 3, so the formula in A3 should be =B3+1.
Here is the code I have so far:
Option Explicit
Const MYRANGE As String = "A:A"
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
'If Sh.Name <> "Sheet1" Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
If Intersect(Target, Sh.Range(MYRANGE)) Is Nothing Then Exit Sub
Cancel = True
Target.Rows(2).Insert
Dim newRow As Range
Set newRow = Target.Rows(2)
Dim rowIndex As Long
rowIndex = newRow.row
newRow.Cells(1, 1).Formula = "=B" & rowIndex & "+1"
End Sub
UPDATE: Changing Target.Rows(2).Insert to Target.Offset(1).EntireRow.Insert solves the issue. Leaving the question open for explanations on what is Offset and how it differs from Rows (The property EntireRow does not exist for Rows(2))
You can reduce this code by four lines for the same outcome, pls see below
Note though that your code is updating cells in your target row and below, ie it won't be updating any cell formulae outside column A that reside above your target. Which is probably not an issue but worth mentioning. If you wanted a full update then you would always insert at row2 rather than at target
Option Explicit
Const MYRANGE As String = "A:A"
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
If Target.Cells.Count > 1 Then Exit Sub
If Intersect(Target, Sh.Range(MYRANGE)) Is Nothing Then Exit Sub
Cancel = True
Target.Offset(1).EntireRow.Insert
Target.Offset(1).Formula = "=B" & Target.Row + 1 & "+1"
End Sub
Ran in to a little problem. If I try to paste to multiple cells that are in the range in the code below, I get a run time error 13, type mismatch. The cells in the range may have data other than X but I only want the hyperlink to appear if the cell contains X. It works fine if I just type an X in the cell or if I paste to one cell at a time. I will have times when I want to paste other text to mutiple cells in this range. Thanks to Remnant for his help on the original code. This one last hurdle will put me in the clear. Thx.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rangeLimit As Range
Set rangeLimit = Range
("B9:B37,C9:C37,D9:D37,E9:E37,F9:F37,G9:G37,H9:H37,I9:I37,J9:J37,K9:K37,L9:L37,M9:M37")
If Not Intersect(rangeLimit, Target) Is Nothing Then
If Target = "x" Or Target = "X" Then
Target.Hyperlinks.Add Anchor:=Target, Address:="", SubAddress:="Exceptions!A1",
TextToDisplay:=Target.Value
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rangeLimit As Range
dim c as range
Set rangeLimit = Range("B9:M37")
If Not Intersect(rangeLimit, Target) Is Nothing Then
for each c in Intersect(rangeLimit, Target)
If c.value = "x" Then
c.Hyperlinks.Add Anchor:=c, Address:="", SubAddress:="Exceptions!A1", TextToDisplay:=c.Value
End If
next c
End If
End Sub
When you paste in a range, 'Target' is a set of cells - not just one cell. If you know this code works for one cell, you can loop over all of the cells in the range target, and call the If statement on each of the cells.
Try this modification to the original code.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rangeLimit As Range
Dim cl As Range
Set rangeLimit = Range("B9:B37,C9:C37,D9:D37,E9:E37,F9:F37,G9:G37,H9:H37,I9:I37,J9:J37,K9:K37,L9:L37,M9:M37")
If Not Intersect(rangeLimit, Target) Is Nothing Then
For Each cl In Target
If cl = "x" Or cl = "X" Then
cl.Hyperlinks.Add Anchor:=cl, Address:="", SubAddress:="Exceptions!A1", TextToDisplay:=cl.Value
End If
Next cl
End If
End Sub