I would like to start off with stating that I have virtually no coding experience. I found a VBA snippet online for highlighting an entire selected range (just to as a visual guide):
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
Application.ScreenUpdating = False
' Clear the color of all the cells
Cells.Interior.ColorIndex = 0
With Target
' Highlight the entire column that contain the active cell
.EntireRow.Interior.ColorIndex = 8
End With
Application.ScreenUpdating = True
End Sub
I would like to also have the cursor jump-to column "J". For instance, after performing a search for cells containing the words "strawberry topping" after pressing 'OK' the cell containing that text becomes active and, due to the VBA code, the entire row is highlighted.
The first cell I need to work on is in column "J". Can I also have column J selected along with the row being highlighted?
Thank you so much for your time and would appreciate any help you may have to offer.
My Three cents
If you are using xl2007+ then do not use Target.Cells.Count. Use Target.Cells.CountLarge else you will get an Overflow error if a user tries to select all cells by pressing CTRL + A as Target.Cells.Count can't hold a Long value.
If you want to select the row and the column, you might want to switch off events else you might end up in endless loop.
Since you are working with events, use error handling.
Is this what you are trying?
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Rw As Long, Col As Long
Dim ColName As String
On Error GoTo Whoa
If Target.Cells.CountLarge > 1 Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
' Clear the color of all the cells
'Cells.Interior.ColorIndex = 0
With Target
Rw = .Row
Col = .Column
ColName = Split(Cells(, Col).Address, "$")(1)
' Highlight the entire column that contain the active cell
'.EntireRow.Interior.ColorIndex = 8
Range(ColName & ":" & ColName & "," & Rw & ":" & Rw).Select
End With
LetsContinue:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
End Sub
Related
In sheet1 (which I've Called "MainSheet") I have a sub in my VBA script that check the values of some cells whenever a cell is changed in this sheet. (one of the main actions that will occur when a cell is changed is modifying it's color, green for Cell's with a value, red for empty cells)
But now I've got some other sub's that also change cells (in the main sheet) but in this case I don't need (and don't want) VBA to check the cells and adapt the color to their values after every cell change. (annoying when editing a large amount of cells).
(I've already tried to put this sub in the "ThisWorkbook"part of VBA instead of the Sheet1(MainSheet) part, but unfortunately this made no difference at all).
Question one: is it possible to prevent this?
I also have a correlated problem with another sub that worth mentioning in the same question I think: In this sub a new sheet is created, named and filled with text from a .txt document. Then the sheet will be saved as new workbook, and the sheet will be deleted. (The name of the sheet equals the name it will get when it's saved, and varies ever new occurrence.)
When I'm copying the .txt lines into this sheet one by one, the first sub I mentioned (the one editing cell color) is called. one of the first things happening in this sub is calling my MainSheet. When thin sub is finished the line copying sub will continue but will start pasting the lines in my Main Sheet. I tried to enter lines in this sub that select the sheet with variable name, but it keeps jumping to the MainSheet.
Question two: How do I prevent jumping to the MainSheet?
(Both questions probably could have the same solution.)
The sub that modifies the cell colours:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim j As Integer
'Collor all cells green containing values, collor empty cells red.
''Starts automaticly after every cell change within this sheet
'Huidige Cell onthouden
If Not Intersect(Target, Range("A9:A29")) Is Nothing Then
On Error GoTo bm_Safe_Exit3
Application.EnableEvents = False
If Intersect(Target, Range("A9:A29")).Cells.Count > 1 Then
Application.Undo
MsgBox "Please edit one cell at a time!"
Else
Dim newVal3 As Variant
newVal3 = Target.Value
Range("A9:A29").ClearContents
Target.Value = newVal3
End If
End If
bm_Safe_Exit3:
Application.EnableEvents = True
Set myActiveCell = ActiveCell
Set myActiveWorksheet = ActiveSheet
Set myActiveWorkbook = ActiveWorkbook
Sheets("MainSheet").Select
Range("C5").Select
j = 0
Do While j < 6
If ActiveCell.Offset(0, j).Value = "" Then
ActiveCell.Offset(-1, j).Interior.Color = RGB(255, 0, 0)
Else: ActiveCell.Offset(-1, j).Interior.Color = RGB(0, 255, 0)
End If
j = j + 1
Loop
'Terug naar de voormalig active cell
myActiveWorkbook.Activate
myActiveWorksheet.Activate
myActiveCell.Activate
End Sub
Using .Select and .Activate is inefficient at the best of times; in a Worksheet_Change event macro it can really foul the waters.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
If Not Intersect(Target, Range("A9:A29")) Is Nothing Then
If Intersect(Target, Range("A9:A29")).Cells.Count > 1 Then
Application.Undo
MsgBox "Please edit one cell at a time!"
'intentionally throw an error; no more code run; sent to bm_Safe_Exit
Err.Raise 0
Else
Dim newVal3 As Variant
newVal3 = Intersect(Target, Range("A9:A29")).Cells(1).Value
Range("A9:A29").ClearContents
Intersect(Target, Range("A9:A29")).Cells(1) = newVal3
End If
End If
Dim j As Integer
With Worksheets("MainSheet").Range("C5")
For j = 0 To 6
If Not CBool(Len(.Offset(0, j).Value)) Then
.Offset(-1, j).Interior.Color = RGB(255, 0, 0)
Else
.Offset(-1, j).Interior.Color = RGB(0, 255, 0)
End If
Next j
End With
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
It isn't clear exactly what worksheet this is running under; I hope it isn't the MainSheet as I've used direct referencing to the cells on that worksheet.
See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.
I have a macro that puts the current time into a cell upon editing any row. my problem is that this macro also executes for row 1 which are the titles. So it ends up changing the title of a column to a time.
The macro works fine but still changes the title. I tried the following:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If ActiveCell.Row = 1 Then Exit Sub
Cells(Target.Row, "I").Value = Now
Application.EnableEvents = True
End Sub
The ActiveCell can change to something else after you edit, so use the Target range rather than the ActiveCell. For example, if I hit {enter} to finish my edit, the ActiveCell is now on row 2 rather than 1.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
With Target
If .Row > 1 Then
Cells(.Row, "I").Value = Now
End If
End With
Application.EnableEvents = True
End Sub
I'm using With syntax to show the same Row you are comparing is the one you are editing. You could still put these on separate lines if you wish.
Also, user Jeeped makes a good point about the Application.EnableEvents = True line. It won't run if the row is 1, so they get turned off indefinitely. Better to test for > 1 and only run your update code on that condition.
If you turn off event handling, provide error control that makes sure that events will be re-enabled.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Safe_Exit
Application.EnableEvents = False
Dim r As Long, rw As Long, rng As Range, newTarget As Range
For Each rng In Target
If rng.Column <> 9 Then
If newTarget Is Nothing Then
Set newTarget = rng
Else
Set newTarget = Union(newTarget, rng)
End If
End If
Next rng
For r = 1 To newTarget.Rows.Count
rw = newTarget.Rows(r).Row
If rw > 1 Then _
Cells(rw, "I").Value = Now
Next r
Safe_Exit:
Application.EnableEvents = True
End Sub
If you are pasting or filling a large number of values then Target is all of the cells that changed. You need to guard against the top row while everything else receives the timestamp. When Target is more than a single cell, you only want to timestamp once per row.
And you don't want to turn off event handling then exit without turning it back on again.
Closed. This question does not meet Stack Overflow guidelines. It is not currently accepting answers.
This question appears to be off-topic because it lacks sufficient information to diagnose the problem. Describe your problem in more detail or include a minimal example in the question itself.
Closed 8 years ago.
Improve this question
I can't post an image so I wanted to explain my question in more detail.
I have 2 files: The vlookup formulas are in the Destination File. The vlookup values are in the Source File. The Destination File will be closed. The Source File will be opened. In the Source File, I may change 15 cell values. If so, I want the 15 cells in the Destination File (closed workbook) to be highlighted yellow as they contain the vlookups when I open it. I hope this explains what we're trying to solve.
UPDATE
Instead of highlighting the cells, do you know how to insert a comment in each cell whenever the cell value changes? I would like to comment to say, "Changed cell from 20 to 30".
Try this code (may be time consuming for big ranges with formulas):
in Code module (standart module):
Public cVals As New Dictionary
Sub populateDict()
Dim rng As Range, c As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng = Intersect(.UsedRange, .Range("CP:CV"))
If rng Is Nothing Then Exit Sub
For Each c In rng
cVals(c.Address) = c.Text
Next c
.Calculate
End With
End Sub
in ThisWorkbook module:
Private Sub Workbook_Open()
Application.Calculation = xlCalculationManual
Call populateDict
Application.Calculation = xlCalculationAutomatic
End Sub
in Sheet module:
Private Sub Worksheet_Calculate()
Dim rng As Range, c As Range
Dim rngToColor As Range
On Error GoTo ErrorHandler
Application.EnableEvents = False
'get only used part of the sheet
Set rng = Intersect(Me.UsedRange, Me.Range("CP:CV"))
If rng Is Nothing Then GoTo ExitHere ' if there is no formulas in CP:CV - exit from sub
'reset color for all cells
rng.Interior.Color = xlNone
For Each c In rng
'check if previous value of this cell not equal to current value
If cVals(c.Address) <> c.Text Then
'if so (they're not equal), remember this cell
c.ClearComments
c.AddComment Text:="Changed value from '" & cVals(c.Address) & "' to '" & c.Text & "'"
End If
'store current value of cell in dictionary (with key=cell address)
cVals(c.Address) = c.Text
Next c
ExitHere:
Application.EnableEvents = True
Exit Sub
ErrorHandler:
Resume ExitHere
End Sub
Note that I'm uisng Dictionary object. For working with Dictionary object you should add reference to Microsoft Scripting Runtime library. Go to Tools->References and select Microsoft Scripting Runtime library:
It looks like you want to build something similar to a trading platform to highlight cells linked with RTD formulas. If it is true (or even if you make changes manually), you can achieve your goal by using worksheet_change.
The below procedure looks at cells in columns 12 to 15 (the real-time values that change) and it compares the values in the FmlaRng (which I assume is a fixed range) before the calculate occurs and after. It is important you set your sheet as xlCalculateManual otherwise Excel will calculate the new values before you can record the old ones.
Also, I am not sure if you need to keep the Application.EnableEvents, but I left it there.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim endrow As Long, startrow As Long, i As Long, j As Long
Dim PreValue As Variant
Dim FmlaRng As Range
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
If Target.Column >= 12 And Target.Column <= 15 Then 'This is where the cell initally changes (the lookupvalue cells)
On Error GoTo 0
startrow = 1
endrow = 1000
With Workbooks("Workbook2").sheets("Sheet1") 'You need to change these names
Set FmlaRng = .Range(.Cells(startrow, 94), .Cells(endrow, 100)) 'FmlaRng is where the lookups should be
FmlaRng.Cells.Interior.ColorIndex = 0
PreValue = FmlaRng
Calculate 'This is when vlookups update
For i = LBound(PreValue, 1) To UBound(PreValue, 1)
For j = LBound(PreValue, 2) To UBound(PreValue, 2)
If FmlaRng.Cells(i, j) = PreValue(i, j) Then
Else
FmlaRng.Cells(i, j).Interior.ColorIndex = 36
End If
Next j
Next i
End with
End If
Application.EnableEvents = True
End Sub
This should be simple. When the value of a cell changes I want to trigger some VBA code. The cell (D3) is a calculation from two other cells =B3*C3. I have attempted 2 approaches:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 4 And Target.Row = 3 Then
MsgBox "There was a change in cell D3"
End If
End Sub
Since the cell is a calculation this is not triggered when the value changes, because the calculation remains the same. I also tried:
Private Sub Worksheet_Calculate()
MsgBox "There was a calculation"
End Sub
But I have multiple calculations on the sheet and it triggers multiple times. Is there a way I can identify which calculation changed on the calculation event? Or is there another way I can track when D3 changes?
Could you try something like this? Change the formula to =D3AlertOnChange(B3*C3).
Private D3OldVal As Variant
Public Function D3AlertOnChange(val)
If val <> D3OldVal Then MsgBox "Value changed!"
D3OldVal = val
D3AlertOnChange = val
End Function
Or try
Private Sub Worksheet_Change(ByVal Target As Range)
Dim numdependences As Integer
On Error Resume Next
HasDependents = Target.Dependents.Count
If Err = 0 Then
If InStr(Target.Dependents.Address, "$D$3") <> 0 Then
MsgBox "change"
End If
End If
On Error GoTo 0
End Sub
You need the error control in case you change a cell that has not dependents.
try this:
Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Target.Worksheet.Range("B1")) Is Nothing Then
Call macro
End If
End Sub
looks for a change in value of cell B1, then executes "macro"
If you are only looking at if the Worksheet_Change then it will count a change for anything entered even if it is the same as the previous value. To overcome this I use a Public variable to capture the starting value and compare it.
This is my code to do this. It also allows you omit parts of the worksheet or you can use it to evaluate every cell in the worksheet.
Place this code in the Worksheet.
Public TargetVal As String 'This is the value of a cell when it is selected
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.CountLarge > 1 Then 'If more then one cell is selected do not save TargetVal. CountLarge is used to protect from overflow if all cells are selected.
GoTo EXITNOW
Else
TargetVal = Target 'This sets the value of the TargetVal variable when a cell is selected
End If
EXITNOW:
End Sub
Sub Worksheet_Change(ByVal Target As Range)
'When a cell is modified this will evaluate if the value in the cell value has changed.
'For example if a cell is entered and enter is pressed the value is still evaluated
'We don't want to count it as a change if the value hasn't actually changed
Dim ColumnNumber As Integer
Dim RowNumber As Integer
Dim ColumnLetter As String
'---------------------
'GET CURRENT CELL INFO
'---------------------
ColumnNumber = Target.Column
RowNumber = Target.Row
ColumnLetter = Split(Target.Address, "$")(1)
'---------------------
'DEFINE NO ACTION PARAMETERS
' IF CELL CHANGED IS IN NO ACTION RANGE, EXIT CODE NOW FOR PERFORMANCE IMPROVEMENT OR TO NOT TAKE ACTION
'---------------------
If ColumnNumber <> 4 Then 'This would exempt anything not in Column 4
GoTo EXITNOW
ElseIf RowNumber <> 3 Then 'This would exempt anything not in Row 3
GoTo EXITNOW
'Add Attional ElseIf statements as needed
'ElseIf ColumnNumber > 25 Then
'GoTo EXITNOW
End If
'---------------------
'EVALUATE IF CELL VALUE HAS CHANGED
'---------------------
Debug.Print "---------------------------------------------------------"
Debug.Print "Cell: " & ColumnLetter & RowNumber & " Starting Value: " & TargetVal & " | New Value: " & Target
If Target = TargetVal Then
Debug.Print " No Change"
'CALL MACRO, FUNCTION, or ADD CODE HERE TO DO SOMETHING IF NOT CHANGED
Else
Debug.Print " Cell Value has Changed"
'CALL MACRO, FUNCTION, or ADD CODE HERE TO DO SOMETHING IF CHANGED
End If
Debug.Print "---------------------------------------------------------"
EXITNOW:
End Sub
I have a template file that I want to protect so that users cannot modify formulas. As the sheet is protected, I have written a macro to allow the user to insert rows. I also want a macro to allow the user to delete rows, but I want to prevent the user from deleting certain critical rows (e.g. check totals and headings, etc.).
To this end I have used column L in my template to identify rows that cannot be deleted. For these rows I have the word "keep" in that row of column L. I have written a basic delete macro below but I need to modify it to look in column L of the selected range rRange and Exit Sub if the word "keep" is there.
*Note that rRange could contain a number of adjacent rows so the macro would need to exit if any of those rows fail the test.
Sub DeteteRows()
Dim rRange As Range
On Error Resume Next
Application.DisplayAlerts = False
Set rRange = Application.InputBox(Prompt:= _
"Please use mouse to select a row to Delete.", _
Title:="SPECIFY ROW TO DELETE", Type:=8)
On Error GoTo 0
Application.DisplayAlerts = True
If rRange Is Nothing Then
Exit Sub
Else
rRange.EntireRow.Delete
Range("a1").Select
MsgBox ("Row(s) Deteted")
End If
End Sub
This may not be the best way but it is below. I did not add the delete portion in the last if then else as I figured you can handle that
Sub DeteteRows()
Dim rRange As Range
Dim bKeepFound As Boolean
bKeepFound = False
On Error Resume Next
Application.DisplayAlerts = False
Set rRange = Application.InputBox(Prompt:= _
"Please use mouse to select a row to Delete.", _
Title:="SPECIFY ROW TO DELETE", Type:=8)
On Error GoTo 0
Application.DisplayAlerts = True
If rRange Is Nothing Then
Exit Sub
'dont need the else statement cause you exit the sub if it fails
End If
For Each Row In rRange.Rows
Dim s 'variable to hold the array
s = Split(Row.Address, ":") 'split out the column and row
'remove the $ and convert to a number then check the cell value
If rRange.Cells(CInt(Replace(s(0), "$", "")), 12).Value = "keep" Then
bKeepFound = True
End If
Next Row
'check to see if a row was found to keep
If bKeepFound Then
Exit Sub 'row was found so exit sub
Else
'delete the rows in the range
End If
End Sub