Multiple VBA Worksheet_Change codes

[gordon21032]

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

 

[gordon21032]

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.