Combining 3 Worksheet_Change events

K

Kevo

New Member
Joined
Feb 4, 2024
Messages
16
Office Version
  1. 365
Platform
  1. Windows
Please assist in combining the below 3 VBA Codes as i am having difficulty in having them all work(Excel doesnt allow for me to have more then one Private Sub Worksheet_Change)


VBA Code: 
Option Explicit
Private Sub Worksheet_Change(ByVal Destination As Range)
Dim rngDropdown As Range
Dim oldValue As String
Dim newValue As String
Dim DelimiterType As String
DelimiterType = ", "
Dim DelimiterCount As Integer
Dim TargetType As Integer
Dim i As Integer
Dim arr() As String
 
If Destination.Count > 1 Then Exit Sub
On Error Resume Next
 
Set rngDropdown = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitError
 
If rngDropdown Is Nothing Then GoTo exitError
 
TargetType = 0
    TargetType = Destination.Validation.Type
    If TargetType = 3 Then  ' is validation type is "list"
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        newValue = Destination.Value
        Application.Undo
        oldValue = Destination.Value
        Destination.Value = newValue
        If oldValue <> "" Then
            If newValue <> "" Then
                If oldValue = newValue Or oldValue = newValue & Replace(DelimiterType, " ", "") Or oldValue = newValue & DelimiterType Then ' leave the value if there is only one in the list
                    oldValue = Replace(oldValue, DelimiterType, "")
                    oldValue = Replace(oldValue, Replace(DelimiterType, " ", ""), "")
                    Destination.Value = oldValue
                ElseIf InStr(1, oldValue, DelimiterType & newValue) Or InStr(1, oldValue, newValue & DelimiterType) Or InStr(1, oldValue, DelimiterType & newValue & DelimiterType) Then
                    arr = Split(oldValue, DelimiterType)
                If Not IsError(Application.Match(newValue, arr, 0)) = 0 Then
                    Destination.Value = oldValue & DelimiterType & newValue
                        Else:
                    Destination.Value = ""
                    For i = 0 To UBound(arr)
                    If arr(i) <> newValue Then
                        Destination.Value = Destination.Value & arr(i) & DelimiterType
                    End If
                    Next i
                Destination.Value = Left(Destination.Value, Len(Destination.Value) - Len(DelimiterType))
                End If
                ElseIf InStr(1, oldValue, newValue & Replace(DelimiterType, " ", "")) Then
                    oldValue = Replace(oldValue, newValue, "")
                    Destination.Value = oldValue
                Else
                    Destination.Value = oldValue & DelimiterType & newValue
                End If
                Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", "") & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", "")) ' remove extra commas and spaces
                Destination.Value = Replace(Destination.Value, DelimiterType & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", ""))
                If Destination.Value <> "" Then
                    If Right(Destination.Value, 2) = DelimiterType Then  ' remove delimiter at the end
                        Destination.Value = Left(Destination.Value, Len(Destination.Value) - 2)
                    End If
                End If
                If InStr(1, Destination.Value, DelimiterType) = 1 Then ' remove delimiter as first characters
                    Destination.Value = Replace(Destination.Value, DelimiterType, "", 1, 1)
                End If
                If InStr(1, Destination.Value, Replace(DelimiterType, " ", "")) = 1 Then
                    Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", ""), "", 1, 1)
                End If
                DelimiterCount = 0
                For i = 1 To Len(Destination.Value)
                    If InStr(i, Destination.Value, Replace(DelimiterType, " ", "")) Then
                        DelimiterCount = DelimiterCount + 1
                    End If
                Next i
                If DelimiterCount = 1 Then ' remove delimiter if last character
                    Destination.Value = Replace(Destination.Value, DelimiterType, "")
                    Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", ""), "")
                End If
            End If
        End If
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
 
exitError:
  Application.EnableEvents = True
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
End Sub






Private Sub Worksheet_Change(ByVal Target As Range)

'Refresh All Pivot Tables and Queries in the Workbook
'ThisWorkbook.RefreshAll

'Only Refresh All Pivot Tables

For Each pc in ThisWorkbook.PivotCaches
   pc.Refresh

Next pc



MsgBox ("Source Data has been changed." & vbNewLine & "A;; Pivot Tables and Pivot Charts updated.")

End Sub






Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Target.Calculate

End sub
 
Last edited by a moderator:

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Sort by date Sort by votes
Hi @Kevo

One way to combine multiple procedures of the same name is to rename them with a suffix like "MyProcedure_1", "MyProcedure_2", "MyProcedure_3" and so on and call them in the desired order from a new defined procedure like "MyMainProcedure".

The code could look like this:
VBA Code: 
Private Sub MyProcedure_1(Arguments as ArgumentType)
 'do something...
End Sub
Private Sub MyProcedure_2(Arguments as ArgumentType)
 'do something...
End Sub
Private Sub MyProcedure_3(Arguments as ArgumentType)
 'do something...
End Sub

Private Sub MyMainProcedure()
 Call MyProcedure_1
 Call MyProcedure_2
 Call MyProcedure_3
End Sub

I re-formatted and combined your code and came up with the following result:
VBA Code: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
   Call Worksheet_SelectionChange_1
   Call Worksheet_SelectionChange_2
   Call Worksheet_SelectionChange_3
End Sub

Private Sub Worksheet_Change_1(ByVal Destination As Range)
    Dim rngDropdown As Range
    Dim oldValue As String
    Dim newValue As String
    Dim DelimiterType As String
    DelimiterType = ", "
    Dim DelimiterCount As Integer
    Dim TargetType As Integer
    Dim i As Integer
    Dim arr() As String

    If Destination.Count > 1 Then Exit Sub
    On Error Resume Next

    Set rngDropdown = Cells.SpecialCells(xlCellTypeAllValidation)
    On Error GoTo exitError

    If rngDropdown Is Nothing Then GoTo exitError

    TargetType = 0
    TargetType = Destination.Validation.Type
    If TargetType = 3 Then                       ' is validation type is "list"
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        newValue = Destination.Value
        Application.Undo
        oldValue = Destination.Value
        Destination.Value = newValue
        If oldValue <> "" Then
            If newValue <> "" Then
                If oldValue = newValue Or oldValue = newValue & Replace(DelimiterType, " ", "") Or oldValue = newValue & DelimiterType Then ' leave the value if there is only one in the list
                    oldValue = Replace(oldValue, DelimiterType, "")
                    oldValue = Replace(oldValue, Replace(DelimiterType, " ", ""), "")
                    Destination.Value = oldValue
                ElseIf InStr(1, oldValue, DelimiterType & newValue) Or InStr(1, oldValue, newValue & DelimiterType) Or InStr(1, oldValue, DelimiterType & newValue & DelimiterType) Then
                    arr = Split(oldValue, DelimiterType)
                    If Not IsError(Application.Match(newValue, arr, 0)) = 0 Then
                        Destination.Value = oldValue & DelimiterType & newValue
                    Else:
                        Destination.Value = ""
                        For i = 0 To UBound(arr)
                            If arr(i) <> newValue Then
                                Destination.Value = Destination.Value & arr(i) & DelimiterType
                            End If
                        Next i
                        Destination.Value = Left(Destination.Value, Len(Destination.Value) - Len(DelimiterType))
                    End If
                ElseIf InStr(1, oldValue, newValue & Replace(DelimiterType, " ", "")) Then
                    oldValue = Replace(oldValue, newValue, "")
                    Destination.Value = oldValue
                Else
                    Destination.Value = oldValue & DelimiterType & newValue
                End If
                Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", "") & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", "")) ' remove extra commas and spaces
                Destination.Value = Replace(Destination.Value, DelimiterType & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", ""))
                If Destination.Value <> "" Then
                    If Right(Destination.Value, 2) = DelimiterType Then ' remove delimiter at the end
                        Destination.Value = Left(Destination.Value, Len(Destination.Value) - 2)
                    End If
                End If
                If InStr(1, Destination.Value, DelimiterType) = 1 Then ' remove delimiter as first characters
                    Destination.Value = Replace(Destination.Value, DelimiterType, "", 1, 1)
                End If
                If InStr(1, Destination.Value, Replace(DelimiterType, " ", "")) = 1 Then
                    Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", ""), "", 1, 1)
                End If
                DelimiterCount = 0
                For i = 1 To Len(Destination.Value)
                    If InStr(i, Destination.Value, Replace(DelimiterType, " ", "")) Then
                        DelimiterCount = DelimiterCount + 1
                    End If
                Next i
                If DelimiterCount = 1 Then       ' remove delimiter if last character
                    Destination.Value = Replace(Destination.Value, DelimiterType, "")
                    Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", ""), "")
                End If
            End If
        End If
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If

exitError:
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change_2(ByVal Target As Range)
    'Refresh All Pivot Tables and Queries in the Workbook
    'ThisWorkbook.RefreshAll

    'Only Refresh All Pivot Tables
    For Each pc In ThisWorkbook.PivotCaches
        pc.Refresh
    Next pc
   
    MsgBox ("Source Data has been changed." & vbNewLine & "A;; Pivot Tables and Pivot Charts updated.")
End Sub

Private Sub Worksheet_SelectionChange_3(ByVal Target As Range)
   Target.Calculate
End Sub

Unfortunately I do not have time to "inspect" your code and try to understand what it actually does, but at a first glance my VBA should work for you.

Please let me know if you're experiencing any issues and if it works as you expected it please mark it as a solution.

Kind Regards
Pete
 
Upvote 0
Hi PeteWright

Thank you for the prompt response. i am however getting an error message after removing all my code and inserting your code-"Compile error: Sub or Function not defined" with Private Sub Worksheet_Change(ByVal Target As Range) highlighted in yellow below.

Private Sub Worksheet_Change(ByVal Target As Range)
Call Worksheet_SelectionChange_1
Call Worksheet_SelectionChange_2
Call Worksheet_SelectionChange_3


Just for clarification
my first code is for selecting multiple options from a drop down menu
second code is for refreshing pivot tables
third code is for highlighting selected cell row
 
Upvote 0
I see... had some typos.
The Procedure names didn't match and I forgot to pass the mandatory arguments:
Call Worksheet_SelectionChange_1(Target)
Call Worksheet_SelectionChange_2(Target)
Call Worksheet_SelectionChange_3(Target)
...
Private Sub Worksheet_SelectionChange_3(ByVal Target As Range)

Here is the updated VBA code:
VBA Code: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
   Call Worksheet_Change_1(Target)
   Call Worksheet_Change_2(Target)
   Call Worksheet_Change_3(Target)
End Sub

Private Sub Worksheet_Change_1(ByVal Destination As Range)
    Dim rngDropdown As Range
    Dim oldValue As String
    Dim newValue As String
    Dim DelimiterType As String
    DelimiterType = ", "
    Dim DelimiterCount As Integer
    Dim TargetType As Integer
    Dim i As Integer
    Dim arr() As String

    If Destination.Count > 1 Then Exit Sub
    On Error Resume Next

    Set rngDropdown = Cells.SpecialCells(xlCellTypeAllValidation)
    On Error GoTo exitError

    If rngDropdown Is Nothing Then GoTo exitError

    TargetType = 0
    TargetType = Destination.Validation.Type
    If TargetType = 3 Then                       ' is validation type is "list"
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        newValue = Destination.Value
        Application.Undo
        oldValue = Destination.Value
        Destination.Value = newValue
        If oldValue <> "" Then
            If newValue <> "" Then
                If oldValue = newValue Or oldValue = newValue & Replace(DelimiterType, " ", "") Or oldValue = newValue & DelimiterType Then ' leave the value if there is only one in the list
                    oldValue = Replace(oldValue, DelimiterType, "")
                    oldValue = Replace(oldValue, Replace(DelimiterType, " ", ""), "")
                    Destination.Value = oldValue
                ElseIf InStr(1, oldValue, DelimiterType & newValue) Or InStr(1, oldValue, newValue & DelimiterType) Or InStr(1, oldValue, DelimiterType & newValue & DelimiterType) Then
                    arr = Split(oldValue, DelimiterType)
                    If Not IsError(Application.Match(newValue, arr, 0)) = 0 Then
                        Destination.Value = oldValue & DelimiterType & newValue
                    Else:
                        Destination.Value = ""
                        For i = 0 To UBound(arr)
                            If arr(i) <> newValue Then
                                Destination.Value = Destination.Value & arr(i) & DelimiterType
                            End If
                        Next i
                        Destination.Value = Left(Destination.Value, Len(Destination.Value) - Len(DelimiterType))
                    End If
                ElseIf InStr(1, oldValue, newValue & Replace(DelimiterType, " ", "")) Then
                    oldValue = Replace(oldValue, newValue, "")
                    Destination.Value = oldValue
                Else
                    Destination.Value = oldValue & DelimiterType & newValue
                End If
                Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", "") & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", "")) ' remove extra commas and spaces
                Destination.Value = Replace(Destination.Value, DelimiterType & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", ""))
                If Destination.Value <> "" Then
                    If Right(Destination.Value, 2) = DelimiterType Then ' remove delimiter at the end
                        Destination.Value = Left(Destination.Value, Len(Destination.Value) - 2)
                    End If
                End If
                If InStr(1, Destination.Value, DelimiterType) = 1 Then ' remove delimiter as first characters
                    Destination.Value = Replace(Destination.Value, DelimiterType, "", 1, 1)
                End If
                If InStr(1, Destination.Value, Replace(DelimiterType, " ", "")) = 1 Then
                    Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", ""), "", 1, 1)
                End If
                DelimiterCount = 0
                For i = 1 To Len(Destination.Value)
                    If InStr(i, Destination.Value, Replace(DelimiterType, " ", "")) Then
                        DelimiterCount = DelimiterCount + 1
                    End If
                Next i
                If DelimiterCount = 1 Then       ' remove delimiter if last character
                    Destination.Value = Replace(Destination.Value, DelimiterType, "")
                    Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", ""), "")
                End If
            End If
        End If
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If

exitError:
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change_2(ByVal Target As Range)
    'Refresh All Pivot Tables and Queries in the Workbook
    'ThisWorkbook.RefreshAll

    'Only Refresh All Pivot Tables
    For Each pc In ThisWorkbook.PivotCaches
        pc.Refresh
    Next pc
   
    MsgBox ("Source Data has been changed." & vbNewLine & "A;; Pivot Tables and Pivot Charts updated.")
End Sub

Private Sub Worksheet_Change_3(ByVal Target As Range)
   Target.Calculate
End Sub

But I get an error on line Set rngDropdown = Cells.SpecialCells(xlCellTypeAllValidation) telling me that no cells were found.
Probably that's because I have no data on my sheet, it's empty.

From within your Worksheet it should work though...
 
Upvote 0
Solution
Thank YOU SO MUCH PeteWright..Code works like a charm:).....Just had to move around other code that i had on my sheet...Thanks so much again and God bless....(Will definitely Mark as a Solution)
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question Question
Can you combine these 2 macros ?
Replies
6
Views
231
excel4us
E
welshraz
  • Question Question
VBA - Restrict Code to One Column for Multi-choice Dropdown
Replies
2
Views
130
welshraz
welshraz
J
  • Question Question
Multiple select validation list VBA
Replies
1
Views
216
jkpieterse
jkpieterse
M
  • Question Question
Help making my VBA code apply to only one column
Replies
2
Views
595
Alex Blakenburg
A
R
  • Question Question
How to combine the functions of having the ability to select multiple items from a drop down list and hide columns based on values of said list?
Replies
0
Views
396
rgree05
R

Forum statistics

Threads
1,224,813
Messages
6,181,114
Members
453,021
Latest member
Justyna P

Share this page

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
Back
Top