I have two ranges of data that I want to compare with and format if they match. So I want to format a range 1 cell if any of that data matches to the the data in range 2. This is what I have so far - it works until I change the data to range 2 but doesn't update it:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim myRange As Range, cell As Range
Set myRange = Range("a9:a12")
For Each cell In myRange
If cell.Value = ActiveCell.Value And Not IsEmpty(ActiveCell.Value) Then
ActiveCell.Interior.ColorIndex = 3
End If
Next cell
End Sub
The problem is the cell still stays the colors that it was formatted from the first block of code so how can I change it back if the data in the second range gets changed?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRange1 As Range
Set myRange1 = Range("f9:f12")
If Not Intersect(Target, Range("f1:f6")) Is Nothing Then
If Application.WorksheetFunction.CountIf(myRange1, ActiveCell.Value) > 0 _
Then ActiveCell.Interior.ColorIndex = 3 Else ActiveCell.Interior.Color = xlNone
End If
End Sub
Is this what you are trying?
If cell.Value = ActiveCell.Value And _
Not IsEmpty(ActiveCell.Value) Then
ActiveCell.Interior.ColorIndex = 3
Else
ActiveCell.Interior.Color = xlNone
End If
EDIT
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim myRange As Range
Set myRange = Range("a9:a12")
If Application.WorksheetFunction.CountIf(myRange, ActiveCell.Value) > 0 _
Then ActiveCell.Interior.ColorIndex = 3 Else ActiveCell.Interior.Color = xlNone
End Sub
EDIT
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRange As Range
Set myRange = Range("f9:f12")
If Not Intersect(Target, myRange) Is Nothing Then
If Application.WorksheetFunction.CountIf(myRange, Target.Value) > 0 _
Then Target.Interior.ColorIndex = 3 Else Target.Interior.Color = xlNone
End If
End Sub
You seem to be taking a somewhat inefficient route with your loop and are ignoring one of the tools (e.g. Target) that is being provided to you.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'important for _SelectionChange event macros
'only process the cells to the extents of the data, not whole rows or columns
If Not Intersect(Target, Target.Parent.UsedRange) Is Nothing Then
Dim c As Range
For Each c In Intersect(Target, Target.Parent.UsedRange)
c.Interior.ColorIndex = 3 + _
4145 * IsError(Application.Match(c.Value2, Range("A9:A12"), 0))
Next c
End If
End Sub
For a Worksheet_SelectionChange event macro, the Target represents one or more cells that is the current Selection. By cycling through each of the cells in the current selection, you can perform this pseudo-Conditional Formatting on a larger range. The Target or Selection can be any number of cells up to the total number of cells in a worksheet but the ActiveCell property can only ever be a single cell.
I've reduced the color on/color off switch to a single worksheet MATCH function and a little maths. This does away with looping through the criteria cells.
Because you may want to select entire row(s) or column(s) at some point, I've included a cell processing 'limit' that will process to the extents of the data on the worksheet. Without a cap on the cells to process, it is very easy to get caught up in the unnecessary processing of entire rows or columns of blank cells when using Worksheet_SelectionChange.
Related
I'm currently learning the automatically triggered macro for a cell. I am curious if this can apply to a range of cells instead of 1 by 1?
My case is: If I input in any cell in column A, "Hello" will appear in column B in the corresponding row. My question is that what if, for instance, I input in A1 (then B1 will appear "Hello"), then I drag from A1 to A10, how can I make the macro automatically apply to B2 -> B10? Currently, I run into the "run time error '13' - Type mismatch".
My current script:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
i = Target.Row
If Not Intersect(Target, Range("A:A")) Is Nothing Then
If Target <> "" Then
Cells(i, 2) = "Hello"
Else
Cells(i, 2).ClearContents
End If
End If
End Sub
Use Offset, which is relative, and loop through Target if it is multiple cells.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer, r As Range
If Not Intersect(Target, Range("A:A")) Is Nothing Then
For Each r In Intersect(Target, Range("A:A")
If r <> "" Then
r.Offset(, 1).Value = "Hello"
Else
r.Offset(, 1).ClearContents
End If
Next r
End If
End Sub
I have an excel sheet that should behave a specific way.
For example the cells I11 - I20 are user input cells in the form of a drop down.
For these cells I need to monitor if a user selects a value that is less than the number 900.
If a user selects a number less than 900 for cell I11 for example, I need to set cells K11 formula to = J11.
If a user selects a number greater than 900, then i clear the formula and allow the cell to be user input.
I need to do this for all cells that range from I11-I20.
Here is what i have for one cell, however i get an error that states "Object variable or With block variable not set" and this only allows me to change one row.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range
Set A = Range("I11")
If Intersect(Target, A) > 900 Then A.Offset(0, 2).Value = ""
Application.EnableEvents = False
A.Offset(0, 2).Value = "=J11"
Application.EnableEvents = True
End Sub
Thank you for any assistance.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count = 1 Then
If Not Intersect(Target, Range("I11:I20")) Is Nothing Then
Application.EnableEvents = False
If Target > 900 Then
Target.Offset(0, 2).ClearContents
Else
Target.Offset(0, 2).Formula = "=J" & Target.Row
End If
Application.EnableEvents = True
End If
End If
End Sub
You have already indicated the target.range, enable events would not be required.
You would not require the formula, just make the cell equal the other cell.
So if there is a change in Column I
And the value is >900, blank the cell 2 columns over. If the change is <=900 then make the cell two columns over equal to the cell 1 column over.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub ' this stops code error if more than one cell is changed at once
If Not Application.Intersect(Target, Me.Range("I1:I100")) Is Nothing Then ' indicates the Target range
If Target > 900 Then
Target.Offset(, 2) = ""
Else: Target.Offset(, 2).Value = Target.Offset(, 1).Value
End If
End If
End Sub
I have a list of priorities in Excel, for example:
4,
1,
3,
2
I want it to automatically update the priorities, if I enter a new name and assigns a priority. For example, if the new name has a priority of 2.
5,
1,
4,
3,
2
I have the following VBA code, which should do the job, but I can't get it to run.
Sub Worksheet_Change(ByVal Target As Range)
Dim rngPriorityList As Range
Dim lNewValue As Integer
Dim myCell As Range
If IsNumeric(Target.Value) Then 'Only run if the a number was entered
Set rngPriorityList = Intersect(Target, Range("I3:I500")) 'the named range for the task list
If Not Intersect(Target, rngPriorityList) Is Nothing Then 'Only run the following in the cell being updated was in the priority list range
If Target.Value >= 1 Then
For Each myCell In rngPriorityList.Cells 'Loop through the priority list range
If myCell.Value = Target.Value _
And myCell.Address <> Target.Address Then 'Finding cells with the same value, excluding the cell being changes
myCell.Value = myCell.Value + 1 'Increment the prioriry by 1
End If
Next myCell
End If
End If
End If
End Sub
a possible correction
wrong setting of rngprioritylist (should be Range("I3:I500" i.o. intersect( ...))
wrong test of mycell.value (should be >= i.o. =)
events should be disabled during the adaptation of the priorities as modifying the priorities will trigger the worksheet_change event.
Sub Worksheet_Change(ByVal Target As Range)
Dim rngPriorityList As Range
Dim lNewValue As Integer
Dim myCell As Range
If IsNumeric(Target.Value) Then 'Only run if the a number was entered
Set rngPriorityList = Range("I3:I500") 'the named range for the task list
If Not Intersect(Target, rngPriorityList) Is Nothing Then 'Only run the following in the cell being updated was in the priority list range
If Target.Value >= 1 Then
Application.EnableEvents = False
For Each myCell In rngPriorityList.Cells 'Loop through the priority list range
If myCell.Value >= Target.Value _
And myCell.Address <> Target.Address Then 'Finding cells with the same value, excluding the cell being changes
myCell.Value = myCell.Value + 1 'Increment the prioriry by 1
End If
Next myCell
Application.EnableEvents = True
End If
End If
End If
End Sub
I have the code below, which will be dependent on triggers, column A and B, to indicate timestamps for each completed entry, however, i keep on getting a runtime error 1004 pop-up:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A2:B501")) Is Nothing Then
Target.Offset(0, 12) = Now
Target.Offset(1, 13) = Now
Target.Offset(0, 14) = Environ("UserName")
End If
End Sub
I'm new to doing VBA, hopefully you guys can help me.
Better way to handle this is something like:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Application.Intersect(Target, Me.Range("A2:B501"))
'Work with "rng", not "Target", since Target might contain cells
' outside of ColA or B...
If Not rng Is Nothing Then
'Target (and so rng) could contain multiple cells
' so need to address them individually
For Each c In rng.Cells
'EDIT:
c.Offset(0, 12) = Now 'ColA >> M, ColB >> N
c.EntireRow.Cells(1, "O") = Environ("UserName")
Next c
End If
End Sub
However since you're handling both ColA and ColB there's a chance you may end up overwriting values since the ranges offset from A and B will overlap
I am looking to do the following using Excel:
Below is a table of booleans and unique identifiers.
This is what I would like to achieve. If the first column says "No", I would like the code to automatically add a whole new row in a separate spreadsheet with the unique identifier in the first column of the new row (shown below is spreadsheet 1).
In this case C4 and C5 would be the two rows exemplified below (spreadsheet 2).
Code updated:
Sub AddID()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
Set Source = ActiveWorkbook.Worksheets("Questionnaire")
Set Target = ActiveWorkbook.Worksheets("AI Tracker")
j = 1
For Each c In Source.Range("C4:C54")
If c = "No" Then
Target.Cells(j + 4, "A").Value = c.Offset(, 1).Value
j = j + 1
End If
Next c
End Sub
This updates the target worksheet correctly but I need it to do update if the Source worksheet is altered (i.e. if something is changed to No, the function should add the new row to the Target sheet).
I have made the following code to detect changes but it does not work:
Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, ActiveWorkbook.Worksheets("Questionnaire").Range("C4:C54")) _
Is Nothing Then
Call Module2.AddID
MsgBox "Cell has changed"
End If
End Sub
instead of
Source.Rows(c.Row).Copy Target.Rows(j)
use
Target.Cells(j,"A").Value = c.Offset(,1).value '<~~ change "A" column index to whatever you need to be copied Unique identifier into
edited
following your further needs and the solution you posted 1 hour ago, consider the following optimization
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, ActiveWorkbook.Worksheets("Questionnaire").Range("C4:C54")) Is Nothing Then Exit Sub '<~~ use just one row and avoid the "Else-End If" block. it increases readability
Dim dest As Worksheet '<~~ Dim only if needed, i.e. if you didn't exit the sub
Set dest = ActiveWorkbook.Worksheets("AI Tracker") '<~~ Set only if needed,i.e. if you didn't exit the sub
If Target.Value = "No" Then dest.Range("A" & dest.Rows.Count).End(xlUp).Offset(1).Value = Target.Offset(, 1).Value '<~~ Target has already all you need and it's already a range
End Sub
still it remains to deal with some conditions. for instance: what if Target is a multiple cells Range?
Things were greatly simplified and I have come up with the following solution:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim n
Dim a
Set dest = ActiveWorkbook.Worksheets("AI Tracker")
If Intersect(Target, ActiveWorkbook.Worksheets("Questionnaire").Range("C4:C54")) Is Nothing Then
Exit Sub
Else
a = Target.Address
n = Range(a).Offset(, 1).Value
If Target.Value = "No" Then
dest.Range("A" & Rows.Count).End(xlUp).Offset(1).Value = n
End If
End If
End Sub
This will detect a "No" and then find the next empty row in the destination worksheet and add the Unique Identifier (associated with the "No") to the first cell in that row.