Combining 2 Worksheet Change Events in 1 Worksheet - excel

Fairly new to VBA and Macros, and I would need assistance in combining these 2 worksheet events. Both work individually and I haven't found a way to combine them to run.
Macro 1: Automatically updating Timestamp Data Entries
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myTableRange As Range
Dim myDateTimeRange As Range
Dim myUpdatedRange As Range
Set myTableRange = Range("W4:W3000")
If Intersect(Target, myTableRange) Is Nothing Then Exit Sub
Application.EnableEvents = False
Set myDateTimeRange = Range("AF" & Target.Row)
Set myUpdatedRange = Range("AG" & Target.Row)
If myDateTimeRange.Value = "" Then
myDateTimeRange.Value = Now
End If
myUpdatedRange.Value = Now
Application.EnableEvents = True
End Sub
Macro 2: Allowing for multiple selection in Dropdown lists
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRng As Range
Dim xValue1 As String
Dim xValue2 As String
If Target.Count > 1 Then Exit Sub
On Error Resume Next
Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
If xRng Is Nothing Then Exit Sub
Application.EnableEvents = False
If Not Application.Intersect(Target, xRng) Is Nothing Then
xValue2 = Target.Value
Application.Undo
xValue1 = Target.Value
Target.Value = xValue2
If xValue1 <> "" Then
If xValue2 <> "" Then
If xValue1 = xValue2 Or _
InStr(1, xValue1, "; " & xValue2) Or _
InStr(1, xValue1, xValue2 & ";") Then
Target.Value = xValue1
Else
Target.Value = xValue1 & "; " & xValue2
End If
End If
End If
End If
Application.EnableEvents = True
End Sub
Any help/guidance would be greatly appreciated.
Thank you!

Create a module and add two subs there:
Option Explicit
Public Sub updateTimestampDataEntries(ByVal c As Range)
'put the code here - using c instead of target
End Sub
Public Sub allowMultipleSelectionDropdown(ByVal c As Range)
'put the code here - using c instead of target
End Sub
Then you can use these subs within your worksheet_events like this
Private Sub Worksheet_Change(ByVal Target As Range)
dim c as Range: set c = Target.Cells(1,1) 'only check the first cell
If Not Application.Intersect(c, rgMyTable) Is Nothing Then
updateTimestampDataEntries c
ElseIf not Application.Intersect(c, rgValidationLists) Is Nothing Then
allowMultipleSelectionDropdown c
End If
End Sub
Private Property Get rgMyTable() as Range
'put your code here
set rgMyTable = ...
End Property
Private Property Get rgValidationLists as range
'put your code here
set rgValidationLists = ...
End Property

Related

Multiple selection in drop down list, but exclude one cell

I'm using a VBA code (that I found online, I'm not very good at VBA) to select multiple items from a drop down list. However I'd like for one of the cells in my Workbook (cell $D$3) to not be affected by this macro. So while it has data validation, you could only select one option. Any help appreciated, I'm trying to learn!
Here's the code I used
Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 2019/11/13
Dim xRng As Range
Dim xValue1 As String
Dim xValue2 As String
If Target.Count > 1 Then Exit Sub
On Error Resume Next
Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
If xRng Is Nothing Then Exit Sub
Application.EnableEvents = False
If Not Application.Intersect(Target, xRng) Is Nothing Then
xValue2 = Target.Value
Application.Undo
xValue1 = Target.Value
Target.Value = xValue2
If xValue1 <> "" Then
If xValue2 <> "" Then
If xValue1 = xValue2 Or _
InStr(1, xValue1, ", " & xValue2) Or _
InStr(1, xValue1, xValue2 & ",") Then
Target.Value = xValue1
Else
Target.Value = xValue1 & ", " & xValue2
End If
End If
End If
End If
Application.EnableEvents = True
End Sub
BigBen commented an answer which solved my problem, thank you!
Here is the revised version which has worked for me:
Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 2019/11/13
Dim xRng As Range
Dim xValue1 As String
Dim xValue2 As String
If Target.Count > 1 Then Exit Sub
On Error Resume Next
If Not Intersect(Target, Me.Range("D3")) Is Nothing Then Exit Sub
Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
If xRng Is Nothing Then Exit Sub
Application.EnableEvents = False
If Not Application.Intersect(Target, xRng) Is Nothing Then
xValue2 = Target.Value
Application.Undo
xValue1 = Target.Value
Target.Value = xValue2
If xValue1 <> "" Then
If xValue2 <> "" Then
If xValue1 = xValue2 Or _
InStr(1, xValue1, ", " & xValue2) Or _
InStr(1, xValue1, xValue2 & ",") Then
Target.Value = xValue1

How to use editable dynamic Dropdown-list

I'm working on an VBA-Code right now, which should:
let you select a text from a dropdown-list
select multiple text and put it on the next line
let you edit the values of the cell.
The Problem here is that when I disable the Error message - so I can edit the cell, the values from the target cell get added to the cell.
So for example I want to edit B to C in the Dropdown cell.
Instead I get A B A C
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim wert_old As String
Dim wertnew As String
On Error GoTo Errorhandling
If Not Application.Intersect(Target, Range("A6")) Is Nothing Then
Set rngDV = Target.SpecialCells(xlCellTypeAllValidation)
If rngDV Is Nothing Then GoTo Errorhandling
If Not Application.Intersect(Target, rngDV) Is Nothing Then
Application.EnableEvents = False
wertnew = Target.Value
Application.Undo
wertold = Target.Value
Target.Value = wertnew
If wertold <> "" Then
If wertnew <> "" Then
Target.Value = wertold & vbCrLf & wertnew
End If
End If
End If
Application.EnableEvents = True
End If
Errorhandling:
Application.EnableEvents = True
End Sub
You must use vbLf as linebreak in cells instead of vbCrLf
Use Option Explicit to prevent using wrong variable names. You declared wert_old but you used wertold. This will easily mess up and drive you nuts. I recommend always to activate Option Explicit: In the VBA editor go to Tools › Options › Require Variable Declaration.
As a workaround you can run your code only if it doesn't contain a vbLf by using
InStr(1, Target.Value, vbLf) < 1
Note that this workaround will make you able to edit the cell if there is more than one item in it but if you try to edit if it only contains one item it will still add it (I have no workaround for that).
So you end up with something like:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Errorhandling
If Not Application.Intersect(Target, Me.Range("A6")) Is Nothing Then
Dim rngDV As Range
Set rngDV = Target.SpecialCells(xlCellTypeAllValidation)
If rngDV Is Nothing Then GoTo Errorhandling
If Not Application.Intersect(Target, rngDV) Is Nothing And InStr(1, Target.Value, vbLf) < 1 Then
Application.EnableEvents = False
Dim WertNew As String
WertNew = Target.Value
Application.Undo
Dim WertOld As String
WertOld = Target.Value
Target.Value = WertNew
If WertOld <> vbNullString Then
If WertNew <> vbNullString Then
Target.Value = WertOld & vbLf & WertNew
End If
End If
End If
Application.EnableEvents = True
End If
Errorhandling:
Application.EnableEvents = True
End Sub

Worksheet_Change multiple events

I'm pretty new to this topic Worksheet_Change. I wanted to put those 3 events together in one sheet. Could someone help me with this problem?
First and second one give me only date and user name in diffrent cells
second one blockes all cells after writing something in it. I have already tried all...
Code 1:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rC As Range
If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each rC In Target.Cells
Range("F" & rC.Row) = Now()
Range("G" & rC.Row) = Environ("username")
Next rC
Application.EnableEvents = True
End Sub
Code 2:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim P2 As Range
If Intersect(Target, Range("C:C")) Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each P2 In Target.Cells
Range("H" & P2.Row) = Now()
Range("I" & P2.Row) = Environ("username")
Next P2
Application.EnableEvents = True
End Sub
Code 3:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel As Range
ActiveSheet.Unprotect Password:="Athens"
For Each cel In Target
If cel.Value <> "" Then
cel.Locked = True
End If
Next cel
ActiveSheet.Protect Password:="Athens"
End Sub
Like so?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rC As Range
Dim P2 As Range
Dim cel As Range
If Not Intersect(Target, Range("B:B")) Is Nothing Then
Application.EnableEvents = False
For Each rC In Target.Cells
Range("F" & rC.Row) = Now()
Range("G" & rC.Row) = Environ("username")
Next rC
Application.EnableEvents = True
ElseIf Not Intersect(Target, Range("C:C")) Is Nothing Then
Application.EnableEvents = False
For Each P2 In Target.Cells
Range("H" & P2.Row) = Now()
Range("I" & P2.Row) = Environ("username")
Next P2
Else
Application.EnableEvents = True
ActiveSheet.Unprotect Password:="Athens"
For Each cel In Target
If cel.Value <> "" Then
cel.Locked = True
End If
Next cel
ActiveSheet.Protect Password:="Athens"
End If
End Sub
needed to change it to make it work as intended. I wanted to block all cells which were modified by direct interaction. Thanks for help! I couldn't do it without your help
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rC As Range
Dim P2 As Range
Dim cel As Range
Application.EnableEvents = True
ActiveSheet.Unprotect Password:="Athens"
For Each cel In Target
If cel.Value <> "" Then
cel.Locked = True
End If
Next cel
ActiveSheet.Protect Password:="Athens"
If Not Intersect(Target, Range("B:B")) Is Nothing Then
Application.EnableEvents = False
For Each rC In Target.Cells
Range("F" & rC.Row) = Now()
Range("G" & rC.Row) = Environ("username")
Next rC
Application.EnableEvents = True
ElseIf Not Intersect(Target, Range("C:C")) Is Nothing Then
Application.EnableEvents = False
For Each P2 In Target.Cells
Range("H" & P2.Row) = Now()
Range("I" & P2.Row) = Environ("username")
Next P2
Application.EnableEvents = True
End If
End Sub

run a macro to change a cell after a value update

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.

Getting column number of cell with particular text using vba

Hi i need to get column of a cell with the text as ACTION.
My current code is as below.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim actionColName 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 = 3 Then
If oldVal = "" Then
'do nothing
Else
If newVal = "" Then
'do nothing
Else
Target.Value = oldVal _
& "+ " & newVal
End If
End If
End If
End If
exitHandler:
Application.EnableEvents = True
End Sub
In the above code there is a condition as below
If Target.Column = 3 Then
Instead of hard coding the value with 3 i would like to apply this logic for the complete column which contains the value ACTION in one of its cell in that column.
Use a Find to determine the (first) column containing Action
Sub GetAction()
Dim rng1 As Range
Set rng1 = ActiveSheet.UsedRange.Find("Action", , xlValues, xlWhole)
If Not rng1 Is Nothing Then
MsgBox "Found in column " & rng1.Column
Else
MsgBox "Not found", vbCritical
End If
End Sub

Resources