I'm trying to apply an excel macro to a cell if there is a certain value in that same row but in a different column. For example, if column A4 has "Yes", then the macro runs on A5.
Currently, I am listing out each of the cells where I need to apply the macro, but I don't want to have to change the macro every single time I need another cell to be added.
The code I have currently right now is as below.
Thank you!
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lUsed As Long
Dim iselect As Range
If Target.Count > 1 Then GoTo exitHandler
On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Intersect(Target, rngDV) Is Nothing Then
'do nothing
Else
Application.EnableEvents = False
newVal = Target.Value
Application.Undo
oldVal = Target.Value
Target.Value = newVal
Set iselect = Application.Intersect(Target, Range("F28,F30,F77,F125,F176:F183,F185,F194,F196,F198:F205,F226,F364,F397,F400,F403,F451,F456,F545,F570,F572,F600,F605,F632,F638,F641,F646,F648,F673,F704,F706,F708,F712,F714,F716,F736,F765,F768,F798,F821,F823,F855,F884,F908,F947,F983:F984,F1009,F1015,F1026,F1033"))
If Intersect(Target, iselect).Address = Target.Address Then
If oldVal = "" Then
'do nothing
Else
If newVal = "" Then
'do nothing
Else
lUsed = InStr(1, oldVal, newVal)
If lUsed > 0 Then
If Right(oldVal, Len(newVal)) = newVal Then
Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2)
Else
Target.Value = Replace(oldVal, newVal, "")
End If
Else
Target.Value = oldVal _
& "," & Chr(10) & newVal
End If
End If
End If
End If
End If
exitHandler:
Application.EnableEvents = True
End Sub
Related
The following does what I want it to by adding formulas when a value is entered into the Target cell, and then deletes said value when the cell is empty.
However, I keep running into a Debug Error if I were to right-click and delete that row within the Target Range, is there a way to prevent this from happening?
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C11:C1000")) Is Nothing Then
If Target.Value <> "" Then
Target.Offset(0, -1).Formula = "=VLOOKUP(" & Target.Address & ",UIDs!$F$3:$H$750,3,FALSE)"
Else:
Target.Offset(0, -1).Value = ""
End If
End If
End Sub
Debug Error:
Then it takes me to If Target.Value <> "" Then if I click Debug.
You can confirm that Target is only 1 cell (as it will be a lot more than that when you delete a row):
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("C11:C1000")) Is Nothing Then
If Target.Count > 1 Then Exit Sub
Application.EnableEvents = False
If Target.Value <> "" Then
Target.Offset(0, -1).Formula = "=VLOOKUP(" & Target.Address & ",UIDs!$F$3:$H$750,3,FALSE)"
Else
Target.Offset(0, -1).Value = ""
End If
Application.EnableEvents = True
End If
End Sub
I am trying to take some code is functioning on a single sheet and convert it so that it applies to all worksheets in the book. I thought I could move the code a module and then use the Workbook_SheetChange "wrapper" described in Worksheet change event for every sheet in the workbook. However, the Multiple Select dropdown still only works on the original sheet, despite the "Named_Range" being defined on all sheets.
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
With Sh
Dim OldVal As String
Dim NewVal As String
' If more than 1 cell is being changed
If Target.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
If Not Intersect(Target, ActiveSheet.Range("Named_Range")) Is Nothing Then
' Turn off events so our changes don't trigger this event again
Application.EnableEvents = False
NewVal = Target.Value
' If there's nothing to undo this will cause an error
On Error Resume Next
Application.Undo
On Error GoTo 0
OldVal = Target.Value
' If selection is already in the cell we want to remove it
If InStr(OldVal, NewVal) Then
'If there's a comma in the cell, there's more than one word in the cell
If InStr(OldVal, ",") Then
If InStr(OldVal, ", " & NewVal) Then
Target.Value = Replace(OldVal, ", " & NewVal, "")
Else
Target.Value = Replace(OldVal, NewVal & ", ", "")
End If
Else
' If we get to here the selection was the only thing in the cell
Target.Value = ""
End If
Else
If OldVal = "" Then
Target.Value = NewVal
Else
' Delete cell contents
If NewVal = "" Then
Target.Value = ""
Else
' This IF prevents the same value appearing in the cell multiple times
' If you are happy to have the same value multiple times remove this IF
If InStr(Target.Value, NewVal) = 0 Then
Target.Value = OldVal & ", " & NewVal
End If
End If
End If
End If
Application.EnableEvents = True
Else
Exit Sub
End If
End With
End Sub
Regular modules don't have events. They are host agnostic. The SheetChange event is in the workbook object. So this means you must place your code into the ThisWorkBook object.
Now looking at your code I see a With Sh block that does nothing. You never use that object. The only place where it makes sense to use the sheet object is where you cite ActiveSheet. We always want to use Sh and we never want to assume that the correct sheet is active.
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim OldVal As String
Dim NewVal As String
' If more than 1 cell is being changed
If Target.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
If Not Intersect(Target, Sh.Range("Named_Range")) Is Nothing Then
' Turn off events so our changes don't trigger this event again
Application.EnableEvents = False
NewVal = Target.Value
' If there's nothing to undo this will cause an error
On Error Resume Next
Application.Undo
On Error GoTo 0
OldVal = Target.Value
' If selection is already in the cell we want to remove it
If InStr(OldVal, NewVal) Then
'If there's a comma in the cell, there's more than one word in the cell
If InStr(OldVal, ",") Then
If InStr(OldVal, ", " & NewVal) Then
Target.Value = Replace(OldVal, ", " & NewVal, "")
Else
Target.Value = Replace(OldVal, NewVal & ", ", "")
End If
Else
' If we get to here the selection was the only thing in the cell
Target.Value = ""
End If
Else
If OldVal = "" Then
Target.Value = NewVal
Else
' Delete cell contents
If NewVal = "" Then
Target.Value = NewVal
Else
' This IF prevents the same value appearing in the cell multiple times
' If you are happy to have the same value multiple times remove this IF
If InStr(Target.Value, NewVal) = 0 Then
Target.Value = OldVal & ", " & NewVal
End If
End If
End If
End If
Application.EnableEvents = True
Else
Exit Sub
End If
End Sub
Finally, there is a logic flaw at the bottom of your if tree. If oldval is not in newval, oldval is not blank and new val is not blank you end up in that final place where it optinally adds a comma. If the that isn't needed then you're in a state where you have run .Undo on the change and you haven't set Target.Value at all. This might make it so you can't change the contents of a cell to a new value. I'm not sure if you intended that behavior.
I'm attempting to add a second code to a single worksheet and keep getting the "Ambiguous name detected" error. Realise that I need to combine the two codes but having trouble doing so. here are the two codes, one below the other:
Private Sub Worksheet_Change(ByVal Target As Range)
'are changes made within answer range?
Set isect = Application.Intersect(Target, Range("Answers"))
If Not (isect Is Nothing) Then
For Each chng In Target.Cells
'Get row number
startY = Impact.Range("Answers").Row
targetY = chng.Row
row_offset = (targetY - startY) + 1
rating_type = Impact.Range("Impacts").Cells(row_offset, 1)
If rating_type = "Major / V.High" Then cols = 16711884
If rating_type = "Significant / High" Then cols = 255
If rating_type = "Important / Moderate" Then cols = 49407
If rating_type = "Minor / Low" Then cols = 5287936
If rating_type = "" Then cols = 16777215
Impact.Range("Ratings").Cells(row_offset, 1).Interior.Color = cols
Impact.Range("Impacts").Cells(row_offset, 1).Interior.Color = cols
Next chng
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
' To Select Multiple Items from a Drop Down List in Excel
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Target.Address = "$C$2" Then
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
GoTo Exitsub
Else: If Target.Value = "" Then GoTo Exitsub Else
Application.EnableEvents = False
Newvalue = Target.Value
Application.Undo
Oldvalue = Target.Value
If Oldvalue = "" Then
Target.Value = Newvalue
Else
If InStr(1, Oldvalue, Newvalue) = 0 Then
Target.Value = Oldvalue & ", " & Newvalue
Else:
Target.Value = Oldvalue
End If
End If
End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub
Was hoping someone knows how to combine the two in order to circumvent this error.
Thanks in advance!
Based on my comment, you can track changes in more than one range as shown in the below sample code.
Private Sub Worksheet_Change(ByVal Target As Range)
'Exit the sub if more than one cells are changed at the same time
If Target.CountLarge > 1 Then Exit Sub
'Disable the event so that if the code changes the cell content of any cell, the code is not triggered again
Application.EnableEvents = False
'Error handling to skip the code if an error occurs during the code execution and enable the events again
On Error GoTo ErrorHandling
'Change event code will be triggered if any cell in column A is changed
If Not Intersect(Target, Range("A:A")) Is Nothing Then
MsgBox "The content of a cell in colunm A has been changed."
'Change event code will be triggered if any cell in column C is changed
ElseIf Not Intersect(Target, Range("C:C")) Is Nothing Then
MsgBox "The content of a cell in colunm C has been changed."
'Change event code will be triggered if any cell in column E is changed
ElseIf Not Intersect(Target, Range("E:E")) Is Nothing Then
MsgBox "The content of a cell in colunm E has been changed."
End If
ErrorHandling:
Application.EnableEvents = True
End Sub
I need to reference an entire column of Excel spreadsheet, with a drop-down list using VBA. The code i got online works only for a single cell which is "$M$2". How can i define a range for the entire column?
Private Sub Worksheet_Change(ByVal Target As Range)
' To Select Multiple Items from a Drop Down List in Excel
Dim Oldvalue As String
Dim Newvalue As String
On Error GoTo Exitsub
If Target.Address = "$M$2" Then
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
GoTo Exitsub
Else: If Target.Value = "" Then GoTo Exitsub Else
Application.EnableEvents = False
Newvalue = Target.Value
Application.Undo
Oldvalue = Target.Value
If Oldvalue = "" Then
Target.Value = Newvalue
Else
Target.Value = Oldvalue & ", " & Newvalue
End If
End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub
Firstly, Target may be a single cell or multiple cells, depending on what the user changed
To test if any cell in (and only in) column M changed, use
If Target.EntireColumn.Address = "$M:$M" Then
To test if any cell in Target is in column M use
Dim rng As Range
Set rng = Application.Intersect(Target, Me.Columns("M"))
If Not rng Is Nothing Then
Note: the rest of your code will need to be modified to allow for Target being more than one cell
I have been looking for days to solve this and have only come up with half the solution.
What I can do:
I would simply like to have one cell turn green inside with an x inserted when another cells data has the word "Complete" inside it.
What I cannot do:
I would like that same cell that turned green with an x inserted into it when the word "Complete" is changed to "Rework" to stay green with an x.
So Cell A1 is blank then in cell B1 the word "Complete" is added. Then cell A1 changes to green and has an x inside it. If later B1 changes to "Rework" I would like A1 to stay green with the x inside. So I can know that at one time the status of B1 was at one time "Complete"
I have been trying Conditional Formatting with rules but cannot get it to stay. I think the "Stop If True" check box within would be part of the solution but not sure what the code would be.
I already have a different macro running on this sheet so if the answer is a macro I will need it to be added to it. Below is the macro in the sheet already. Thank you.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("N:N,Y:Y"), Range("10:" & Rows.Count)) Is Nothing Then
If Target.Count < Columns.Count Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
Dim r As Range
For Each r In Intersect(Target, Range("N:N,Y:Y"), Range("10:" & Rows.Count))
With r.Offset(0, 1)
.Value = Now 'use Now to retain the time as well as the date
.NumberFormat = "mm/dd/yy" 'change to what you prefer
End With
Next r
End If
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
Ideally you'd split this up into separate subs to handle each of the change types, but this should give you an idea:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, r as Range
'skip full-row changes (row insert/delete?)
If Target.Columns.Count = Columns.Count Then Exit Sub
Set rng = Intersect(Target, Range("N:N,Y:Y"), Range("10:" & Rows.Count))
If Not rng Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
For Each r In rng.Cells
With r.Offset(0, 1)
.Value = Now 'use Now to retain the time as well as the date
.NumberFormat = "mm/dd/yy" 'change to what you prefer
End With
Next r
End If
Set rng = Intersect(Target, Range("B:B"), Range("10:" & Rows.Count))
If Not rng Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
For Each r In rng.Cells
If r.Value = "Complete" Then
With r.Offset(0, -1)
.Value = "x"
.Interior.Color = vbGreen
End With '<<EDIT thanks #BruceWayne
End If
Next r
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
You'll need two worksheet events, and some If statements. The following should help you get started, unless I'm overlooking something.
Dim oldVal as String ' Public variable
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Debug.Print Target.Address
If Target.Cells.Count <> 1 Then Exit Sub
oldVal = Target.Value
End Sub
The above will make note of the oldValue.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim newVal As String
newVal = Target.Value
If newVal = oldVal Then
Debug.Print "Same Values"
ElseIf oldVal = "Complete" And newVal = "Rework" Then
Debug.Print "Stay green with X"
ElseIf oldVal = "" And (newVal = "Complete" Or newVal = "complete") Then
Debug.Print "Change cell to Green, add an 'X'"
Target.Interior.ColorIndex = 10
Target.Value = Target.Value & " x"
End If
End Sub
Then, add/tweak those If statements as necessary, and add the color changing/reverting code to the appropriate block.
(There may of course be a better mousetrap, but I think this should get you going).