Multiple VBA Worksheet_Change codes

gordon21032

New Member
Joined
Mar 2, 2021
Messages
2
Office Version
  1. 365
Platform
  1. Windows
Hi everyone,

I'm trying to combine multiple VBA codes in one worksheet. I have managed to do this previously for several codes of a similar nature which are shown below for reference. These codes all performed the same purpose, to auto populate certain cells with the date and user who made modified a target range of cells. To achieve this, I added in the blue section (see below) and amended the title of each Worksheet_Change to include a letter, such as Private Sub Worksheet_Change_A(ByVal Target As Excel.Range).

I now want to add a slightly different Worksheet_Change to allow me (on the same worksheet) to select multiple options for a cell from a drop down list. I have found a successful VBA code for this on a forum, but when I try to add it to the current VBA codes that I have, using the same methodology, it doesn't work (ie: won't show multiple values like I want it to). Interestingly, if I delete my old code and just use the one from the forum on it's own, there are no issues, so there must be something I am doing wrong!

Here is my current code that works without issue:

Private Sub Worksheet_Change(ByVal Target As Range)
Worksheet_Change_A Target
Worksheet_Change_B Target
Worksheet_Change_C Target
Worksheet_Change_D Target
Worksheet_Change_E Target
Worksheet_Change_F Target
Worksheet_Change_G Target
Worksheet_Change_H Target
Worksheet_Change_I Target
End Sub


Private Sub Worksheet_Change_A(ByVal Target As Excel.Range)
'Updated by Extendoffice 2017/10/12
Dim xRg As Range, xCell As Range
On Error Resume Next
If (Target.Count = 1) Then
If (Not Application.Intersect(Target, Me.Range("H18:H1000")) Is Nothing) Then _
Target.Offset(0, 2) = Date
Application.EnableEvents = False
Set xRg = Application.Intersect(Target.Dependents, Me.Range("H18:H1000"))
If (Not xRg Is Nothing) Then
For Each xCell In xRg
xCell.Offset(0, 2) = Date
Next
End If
Application.EnableEvents = True
End If
End Sub

Private Sub Worksheet_Change_B(ByVal Target As Excel.Range)
'Updated by Extendoffice 2017/10/12
Dim xRg As Range, xCell As Range
On Error Resume Next
If (Target.Count = 1) Then
If (Not Application.Intersect(Target, Me.Range("H18:H1000")) Is Nothing) Then _
Target.Offset(0, 3) = Environ$("UserName")
Application.EnableEvents = False
Set xRg = Application.Intersect(Target.Dependents, Me.Range("H18:H1000"))
If (Not xRg Is Nothing) Then
For Each xCell In xRg
xCell.Offset(0, 3) = Environ$("UserName")
Next
End If
Application.EnableEvents = True
End If
End Sub

Private Sub Worksheet_Change_C(ByVal Target As Excel.Range)
'Updated by Extendoffice 2017/10/12
Dim xRg As Range, xCell As Range
On Error Resume Next
If (Target.Count = 1) Then
If (Not Application.Intersect(Target, Me.Range("I18:I1000")) Is Nothing) Then _
Target.Offset(0, 1) = Date
Application.EnableEvents = False
Set xRg = Application.Intersect(Target.Dependents, Me.Range("I18:I1000"))
If (Not xRg Is Nothing) Then
For Each xCell In xRg
xCell.Offset(0, 1) = Date
Next
End If
Application.EnableEvents = True
End If
End Sub

Private Sub Worksheet_Change_D(ByVal Target As Excel.Range)
'Updated by Extendoffice 2017/10/12
Dim xRg As Range, xCell As Range
On Error Resume Next
If (Target.Count = 1) Then
If (Not Application.Intersect(Target, Me.Range("I18:I1000")) Is Nothing) Then _
Target.Offset(0, 2) = Environ$("UserName")
Application.EnableEvents = False
Set xRg = Application.Intersect(Target.Dependents, Me.Range("I18:I1000"))
If (Not xRg Is Nothing) Then
For Each xCell In xRg
xCell.Offset(0, 2) = Environ$("UserName")
Next
End If
Application.EnableEvents = True
End If
End Sub

Private Sub Worksheet_Change_E(ByVal Target As Excel.Range)
'Updated by Extendoffice 2017/10/12
Dim xRg As Range, xCell As Range
On Error Resume Next
If (Target.Count = 1) Then
If (Not Application.Intersect(Target, Me.Range("L18:L1000")) Is Nothing) Then _
Target.Offset(0, 2) = Date
Application.EnableEvents = False
Set xRg = Application.Intersect(Target.Dependents, Me.Range("L18:L1000"))
If (Not xRg Is Nothing) Then
For Each xCell In xRg
xCell.Offset(0, 2) = Date
Next
End If
Application.EnableEvents = True
End If
End Sub

Private Sub Worksheet_Change_F(ByVal Target As Excel.Range)
'Updated by Extendoffice 2017/10/12
Dim xRg As Range, xCell As Range
On Error Resume Next
If (Target.Count = 1) Then
If (Not Application.Intersect(Target, Me.Range("L18:L1000")) Is Nothing) Then _
Target.Offset(0, 3) = Environ$("UserName")
Application.EnableEvents = False
Set xRg = Application.Intersect(Target.Dependents, Me.Range("L18:L1000"))
If (Not xRg Is Nothing) Then
For Each xCell In xRg
xCell.Offset(0, 3) = Environ$("UserName")
Next
End If
Application.EnableEvents = True
End If
End Sub

Private Sub Worksheet_Change_G(ByVal Target As Excel.Range)
'Updated by Extendoffice 2017/10/12
Dim xRg As Range, xCell As Range
On Error Resume Next
If (Target.Count = 1) Then
If (Not Application.Intersect(Target, Me.Range("M18:M1000")) Is Nothing) Then _
Target.Offset(0, 1) = Date
Application.EnableEvents = False
Set xRg = Application.Intersect(Target.Dependents, Me.Range("M18:M1000"))
If (Not xRg Is Nothing) Then
For Each xCell In xRg
xCell.Offset(0, 1) = Date
Next
End If
Application.EnableEvents = True
End If
End Sub

Private Sub Worksheet_Change_H(ByVal Target As Excel.Range)
'Updated by Extendoffice 2017/10/12
Dim xRg As Range, xCell As Range
On Error Resume Next
If (Target.Count = 1) Then
If (Not Application.Intersect(Target, Me.Range("M18:M1000")) Is Nothing) Then _
Target.Offset(0, 2) = Environ$("UserName")
Application.EnableEvents = False
Set xRg = Application.Intersect(Target.Dependents, Me.Range("M18:M1000"))
If (Not xRg Is Nothing) Then
For Each xCell In xRg
xCell.Offset(0, 2) = Environ$("UserName")
Next
End If
Application.EnableEvents = True
End If
End Sub

And here is the code I want to add:

Private Sub Worksheet_Change_I(ByVal Target As Range)
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Target.Column = 13 And (Target.Row >= 18 And Target.Row <= 1000) 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 & vbNewLine & Newvalue
Else:
Target.Value = Oldvalue
End If
End If
End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub

Any help would be greatly appreciated!

Thanks Cameron
 

Some videos you may like

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.

gordon21032

New Member
Joined
Mar 2, 2021
Messages
2
Office Version
  1. 365
Platform
  1. Windows
Solved the issue myself.

Solution: Instead of making the new VBA that I wanted to add as option 'I', I made it option 'A' and pushed all the others back. Seemed to fix my problem.
 

Watch MrExcel Video

Forum statistics

Threads
1,127,098
Messages
5,622,679
Members
415,921
Latest member
ExcelNoob28

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top