I am using the below codes to change the "Sheet2" "D2" value as per the value in "Sheet1" "B2" and VICE VERSA too. But they are not working together. If I use them separately then both coding is working perfectly. How can I correct them to perform together?
"Sheet1"
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B2")) Is Nothing Then
Select Case Target.Value
Case Is = "Included": Worksheets("Sheet2").Range("D2") = Target.Value
Case Is = "Excluded": Worksheets("Sheet2").Range("D2") = Target.Value
End Select
End If
End Sub
"Sheet2"
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("D2")) Is Nothing Then
Select Case Target.Value
Case Is = "Included": Worksheets("Sheet1").Range("B2") = Target.Value
Case Is = "Excluded": Worksheets("Sheet1").Range("B2") = Target.Value
End Select
End If
End Sub
From comments above:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, v
Set rng = Intersect(Target, Me.Range("B2"))
If Not rng Is Nothing Then
v = Target.Value
If v = "Included" Or v = "Excluded" Then
On Error GoTo haveError 'set up error handling
Application.EnableEvents = False 'disable events
ThisWorkbook.Worksheets("Sheet2").Range("D2") = v
Application.EnableEvents = True 're-enable events
End If
End If
Exit Sub 'normal exit
haveError:
Application.EnableEvents = True 'make sure events not left turned off
End Sub
Related
I have the following two codes in my sheet, and I want them both to run - currently I get a macro error. Could you help me to combine them so that they both run??
One enters the date in an adjacent cell when data is entered, the other allows multiple selections from a dropdown list. Both work individually.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("O:O"), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
Rng.Offset(0, xOffsetColumn).Value = Now
Rng.Offset(0, xOffsetColumn).NumberFormat = "dd/mm/yyyy"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub
And the other code is:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
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
If Target.Column = 10 _
Or Target.Column = 12 Then
If oldVal = "" Then
'do nothing
Else
If newVal = "" Then
'do nothing
Else
Target.Value = oldVal _
& ", " & newVal
' NOTE: you can use a line break,
' instead of a comma
' Target.Value = oldVal _
' & Chr(10) & newVal
End If
End If
End If
End If
exitHandler:
Application.EnableEvents = True
End Sub
Many thanks
You can only have one Worksheet_Change event per sheet. A simple work around is to turn your two Events into Sub Procedures and then create a master Event that simply calls both of your other subs.
The set up will look something like this
Event
Private Sub Worksheet_Change(ByVal Target As Range)
AddDate Target
Dropdown Target
End Sub
Sub Procedure 1
Sub AddDate (Target as Range)
'Your first code goes here
End Sub
Sub Procedure 2
Sub Dropdown (Target as Range)
'Your second code goes here
End Sub
I would personally set up your validations in the Event and call your procedures accordingly. Then your subs can strictly focus on the action statements rather needing to do any validation.
That may look something like this (notice all of your range variables are already initiated and no longer need to be declared)
Private Sub Worksheet_Change(ByVal Target As Range)
'DateAdd Validation
Dim WorkRng As Range
Set WorkRng = Intersect(Application.ActiveSheet.Range("O:O"), Target)
If Not WorkRng Is Nothing Then
DateAdd Target, WorkRng
End If
'Dropdown Validation
Dim rngDV As Range
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
If Target.Count = 1 Then
If Not rngDV Is Nothing Then '<-- I believe this is redundant
If Not Intersect(Target, rngDV) Is Nothing Then
Dropdown Target, rngDV
End If
End If
End If
End Sub
Sub DateAdd(Target As Range, WorkRng As Range)
End Sub
Sub Dropdown(Target As Range, rngDV As Range)
End Sub
I want to merge two Worksheet_Change events.
The aim of the code is to convert any uppercase text in the cell ranges given to lowercase.
I tried copying both into the same Worksheet_Change, but Excel crashed.
Range 1:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ccr As Range
Set ccr = Range("C6")
For Each Cell In ccr
Cell.Value = LCase(Cell)
Next Cell
End Sub
Range 2:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim acr As Range
Set acr = Range("C9:G9")
For Each Cell In acr
Cell.Value = LCase(Cell)
Next Cell
End Sub
The main issue is that changing a cell value Cell.Value will trigger another Worksheet_Change immediately. You need to Application.EnableEvents = False to prevent this.
Also I recommend to work with Intersect so the code only runs on the cells that are actually changed.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim AffectedRange As Range
Set AffectedRange = Intersect(Target, Target.Parent.Range("C6, C9:G9"))
If Not AffectedRange Is Nothing Then
Application.EnableEvents = False 'pervent triggering another change event
Dim Cel As Range
For Each Cel In AffectedRange.Cells
Cel.Value = LCase$(Cel.Value)
Next Cel
Application.EnableEvents = True 'don't forget to re-enable events in the end
End If
End Sub
In addition to #Frank Ball's comment including error handling:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim AffectedRange As Range
Set AffectedRange = Intersect(Target, Target.Parent.Range("C6, C9:G9"))
Application.EnableEvents = False 'pervent triggering another change event
On Error GoTo ERR_HANDLING
If Not AffectedRange Is Nothing Then
Dim Cel As Range
For Each Cel In AffectedRange.Cells
Cel.Value = LCase$(Cel.Value)
Next Cel
End If
On Error GoTo 0
'no Exit Sub here!
ERR_HANDLING:
Application.EnableEvents = True
If Err.Number <> 0 Then
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End If
End Sub
Like this you can do both the things in same event
You have to add Application.EnableEvents = False at the starting to avoid race condition.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim ccr As Range, acr as Range
Set ccr = Range("C6")
For Each Cell In ccr
Cell.Value = LCase(Cell)
Next Cell
Set acr = Range("C9:G9")
For Each Cell In acr
Cell.Value = LCase(Cell)
Next Cell
Application.EnableEvents = True
End Sub
The two Worksheet_Change events are quite the same, they are a loop around a range, returning LCase(). Thus, it is a good idea to make a separate Sub for it like this:
Sub FixRangeLCase(rangeToFix As Range)
Dim myCell As Range
For Each myCell In rangeToFix
myCell.Value2 = LCase(myCell.Value2)
Next myCell
End Sub
Then, refer the Worksheet_Change event to it. As far as the Worksheet_Change event is quite "expensive", running always, it is a good idea to run it only when a specific Target cell is changed and otherwise exit the procedure - If Intersect(Target, Range("C6"), Range("C9:G9")) Is Nothing Then Exit Sub
The Application.EnableEvents = False is needed to disable the events. At the end it is set back to True.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C6"), Range("C9:G9")) Is Nothing Then Exit Sub
Application.EnableEvents = False
FixRangeLCase Range("C6")
FixRangeLCase Range("C9:G9")
Application.EnableEvents = True
End Sub
Also you can use:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, cell As Range
Application.EnableEvents = False
If Not Intersect(Target, Range("C6")) Is Nothing Or Not Intersect(Target, Range("C9:G9")) Is Nothing Then
Set rng = Range("C9:G9", "C6")
For Each cell In rng
cell.Value = LCase(cell.Value)
Next
End If
Application.EnableEvents = True
End Sub
The code below is causing an error when I paste information onto the sheet.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A1 As Range
Set A1 = Range("A:I")
If Not Intersect(Target, A1) Is Nothing Then
Application.EnableEvents = False
Target.Value = UCase(Target.Value)
Application.EnableEvents = True
End If
End Sub
The code is specific to the sheet (right click on tab an view code).
Could you please advise on how to fix this?
Thanks in advance.
Loop over the intersection cells if they exists:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A1 As Range, intr As Range, r As Range
Set A1 = Range("A:I")
Set intr = Intersect(A1, Target)
If Not intr Is Nothing Then
Application.EnableEvents = False
For Each r In intr
r.Value = UCase(r.Value)
Next r
Application.EnableEvents = True
End If
End Sub
The error is because of Target.Value = UCase(Target.Value) is not suitable for multiple cells. Thus a loop is needed:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo WorksheetChange_Error
Application.EnableEvents = False
Dim A1 As Range
Set A1 = Range("A:I")
If Not Intersect(Target, A1) Is Nothing Then
Dim myCell As Range
For Each myCell In Target.Cells
myCell = UCase(myCell)
Next
End If
Application.EnableEvents = True
Exit Sub
WorksheetChange_Error:
Application.EnableEvents = True
MsgBox Err.Description
End Sub
The error handler is used to reset the EnableEvents = True, if some kind of unexpected error comes.
I know this question has been asked a few times. I want to increase the font size of a drop down list in Excel. I can get it going without any other code in the sheet but I've got a separate sub that hides/unhides specific columns based off values entered into Column B. I'm struggling to combine both functions into the same working sheet.
This is my attempt:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A")) Is Nothing Then
On Error GoTo safe_exit
Application.EnableEvents = False
Dim t As Range
For Each t In Intersect(Target, Range("A:A"))
Select Case (t.Value)
Case "X"
Columns("B:C").EntireColumn.Hidden = False
Columns("D:E").EntireColumn.Hidden = True
Case "Y"
Columns("D:E").EntireColumn.Hidden = False
Columns("B:C").EntireColumn.Hidden = True
'do nothing
End Select
Next t
End If
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A:A")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
ActiveWindow.Zoom = 100
End If
safe_exit:
Application.EnableEvents = True
End Sub
You only need to add the one line from your second sub to the first:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A")) Is Nothing Then
On Error GoTo safe_exit
Application.EnableEvents = False
Dim t As Range
For Each t In Intersect(Target, Range("A:A"))
Select Case (t.Value)
Case "X"
Columns("B:C").EntireColumn.Hidden = False
Columns("D:E").EntireColumn.Hidden = True
Case "Y"
Columns("D:E").EntireColumn.Hidden = False
Columns("B:C").EntireColumn.Hidden = True
'do nothing
End Select
Next t
ActiveWindow.Zoom = 100 '<<<
End If
safe_exit:
Application.EnableEvents = True
End Sub
i'm clueless, i'm trying to build a code that input a prefix to a cell value after i change that cell, i mean i'll select a cell and input "342" for example, after i update that value i want the private sub to change that cell value to "GO-342", i've tried this, but it dosen't work.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$D$3" Then
If Left(Range("D3"), 2) = "GO" Then Exit Sub
Range("D3") = "GO-" & Range("D3")
End If
End Sub
the entire code:
Private Sub Worksheet_Change(ByVal Target As Range)
'Cabeçalho
Dim rng As Range
Set rng = Range("D3,D5,I3,O3,O5,O7,X3,X5")
If Intersect(Target, rng) Is Nothing Then Exit Sub
For Each R In rng
If R.Value = "" Then
Exit Sub
End If
Next R
Create
'Km
Dim rng1 As Range
Set rng1 = Range("X3,X5")
If Intersect(Target, rng1) Is Nothing Then Exit Sub
For Each R In rng1
If R.Value = "" Then
Exit Sub
End If
Next R
Km
'GO
If Target.Address = "$D$3" Then
If Left(Range("D3"), 2) = "GO" Then Exit Sub
Application.EnableEvents = False
Range("D3") = "GO-" & Range("D3")
Application.EnableEvents = True
End If
End Sub
"Cabeçalho" and "Km" works but "GO" dosen't
Here is a tiny mod to your code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$D$3" Then
If Left(Range("D3"), 2) = "GO" Then Exit Sub
Application.EnableEvents = False
Range("D3") = "GO-" & Range("D3")
Application.EnableEvents = True
End If
End Sub
The code must be placed in the worksheet code area.Macros must be enabled.