Combining VBA

J

JackReacher85

Banned user
Joined
Sep 14, 2021
Messages
15
Office Version
  1. 2016
Platform
  1. Windows
Hi all,

Im working on a project where i need multiple VBA codes to be able to run on the one sheet, im not massively excel savvy and ive got the below from other sources. When these codes are on their own they work as intended but when i add them all in they dont work as expected and im a bit stuck. I need the below to be able to work seamlessly as one. In Cell C6 i have a drop down list where i have 5 options to select from, when i select an option i want a message box to appear with information for the user to read, after this in Cell J16 i have a list that allows multiple selections without repetition so i can select several items from the list each separated by a |. From what i have read and researched thus far i know i cant have two Private Sub Worksheet Changes at the same time, ive tried to rename them but to no avail. If any of you kind souls could help on this id be in your debt. Thanks in advance.

VBA Code: 
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
 
If Not Destination.Address = "$J$16" 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) 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(ByVal Target As Range)
 '
    If Not Intersect(Target, Range("C6")) Is Nothing And Target.Cells.Count = 1 Then
        Select Case Target
            Case Is = "NMORI"
                MsgBox "NMORI - Check full history and 5&2 rule"
            Case Is = "CMORI"
                MsgBox "CMORI - Check full history and 5&2 rule"
            Case Is = "CME"
                MsgBox "CME - Check history and exclusions"
            Case Is = "FMU"
                MsgBox "FMU - Check history and exclusions"
            Case Is = "MHD"
                MsgBox "MHD - Take brief history only"
        End Select
    End If
End Sub
 

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
Sort by date Sort by votes
Hi @JackReacher85
Welcome to the MrExcel forum. Please accept my warmest greetings and sincere hope that all is well.


Try the following, replace all your code for this:

Power Query: 
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
  
  If Not Intersect(Destination, Range("J16")) Is Nothing Then
    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) 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
  End If
 
  If Not Intersect(Destination, Range("C6")) Is Nothing Then
      Select Case Destination
          Case Is = "NMORI"
              MsgBox "NMORI - Check full history and 5&2 rule"
          Case Is = "CMORI"
              MsgBox "CMORI - Check full history and 5&2 rule"
          Case Is = "CME"
              MsgBox "CME - Check history and exclusions"
          Case Is = "FMU"
              MsgBox "FMU - Check history and exclusions"
          Case Is = "MHD"
              MsgBox "MHD - Take brief history only"
      End Select
  End If

exitError:
  Application.EnableEvents = True
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​
 
Upvote 0
Solution
Hi,
Where you require multiple addresses to run code from your WorkSheet_Change event another option to consider is to break them in to their own codes & call them from the event as required - this should make your codes easier to read & debug.

For example

Place following code in your worksheets code page

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.CountLarge > 1 Then Exit Sub
    
    If Not Intersect(Target, Me.Range("C6,J16")) Is Nothing Then
    
    Select Case Target.Address(0, 0)
        Case "C6"
            CheckHistory Target
        Case "J16"
            DestinationChange Target
        Case Else
            'other addresses as required
        End Select
  End If
  
End Sub

Place following codes in their own STANDARD Modules

Code: 
Sub CheckHistory(ByVal Target As Range)
    Dim m                  As Variant
    Dim strValidation As String
    
    On Error GoTo myerror
    If Target.Validation.Type = xlValidateList Then
        
        strValidation = Target.Validation.Formula1
        
        m = Application.Match(Target.Value, Split(strValidation, ","), 0)
        If Not IsError(m) Then
            MsgBox Target.Value & " - " & Choose(CLng(m), "Check full history And 5&2 rule", "Check full history And 5&2 rule", _
                                                                                           "Check history And exclusions", "Check history And exclusions", _
                                                                                           "Take brief history only"), 48, "Check History"
        End If
    End If
myerror:
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

Code: 
Sub DestinationChange(ByVal Target As Range)
    Dim rngDropdown     As Range
    Dim oldValue            As String, newValue   As String, arr()    As String
    Dim DelimiterCount  As Long, i                    As Long
    Dim TargetType       As XlDVType
    
    Const DelimiterType As String = " | "
    
    On Error GoTo exitError
    With Application
        .EnableEvents = False: .ScreenUpdating = False
    End With
    
    TargetType = 0
    TargetType = Target.Validation.Type
    ' is validation type is "list"
    If TargetType = xlValidateList Then
        
        newValue = Target.Value
        Application.Undo
        oldValue = Target.Value
        Target.Value = newValue
        If oldValue <> "" Then
            If newValue <> "" Then
                ' leave the value if there is only one in the list
                If oldValue = newValue Or oldValue = newValue & Replace(DelimiterType, " ", "") Or oldValue = newValue & DelimiterType Then
                    oldValue = Replace(oldValue, DelimiterType, "")
                    oldValue = Replace(oldValue, Replace(DelimiterType, " ", ""), "")
                    Target.Value = oldValue
                ElseIf InStr(1, oldValue, DelimiterType & newValue) Then
                    arr = Split(oldValue, DelimiterType)
                    If Not IsError(Application.Match(newValue, arr, 0)) = 0 Then
                        Target.Value = oldValue & DelimiterType & newValue
                    Else:
                        Target.Value = ""
                        For i = 0 To UBound(arr)
                            If arr(i) <> newValue Then
                                Target.Value = Target.Value & arr(i) & DelimiterType
                            End If
                        Next i
                        Target.Value = Left(Target.Value, Len(Target.Value) - Len(DelimiterType))
                    End If
                ElseIf InStr(1, oldValue, newValue & Replace(DelimiterType, " ", "")) Then
                    oldValue = Replace(oldValue, newValue, "")
                    Target.Value = oldValue
                Else
                    Target.Value = oldValue & DelimiterType & newValue
                End If
                ' remove extra commas and spaces
                Target.Value = Replace(Target.Value, Replace(DelimiterType, " ", "") & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", ""))
                Target.Value = Replace(Target.Value, DelimiterType & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", ""))
                If Target.Value <> "" Then
                    'remove delimiter at the end
                    If Right(Target.Value, 2) = DelimiterType Then        '
                    Target.Value = Left(Target.Value, Len(Target.Value) - 2)
                End If
            End If
            ' remove delimiter as first characters
            If InStr(1, Target.Value, DelimiterType) = 1 Then
                Target.Value = Replace(Target.Value, DelimiterType, "", 1, 1)
            End If
            If InStr(1, Target.Value, Replace(DelimiterType, " ", "")) = 1 Then
                Target.Value = Replace(Target.Value, Replace(DelimiterType, " ", ""), "", 1, 1)
            End If
            DelimiterCount = 0
            For i = 1 To Len(Target.Value)
                If InStr(i, Target.Value, Replace(DelimiterType, " ", "")) Then
                    DelimiterCount = DelimiterCount + 1
                End If
            Next i
            ' remove delimiter if last character
            If DelimiterCount = 1 Then
                Target.Value = Replace(Target.Value, DelimiterType, "")
                Target.Value = Replace(Target.Value, Replace(DelimiterType, " ", ""), "")
            End If
        End If
    End If
    
End If

exitError:
With Application
    .EnableEvents = True: .ScreenUpdating = True
End With
'report errors
If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

Codes are untested & you will need to adjust to meet specific project need as required but should give another idea that may help resolve your issue

Dave
 
Upvote 0
DanteAmor said:
Hi @JackReacher85
Welcome to the MrExcel forum. Please accept my warmest greetings and sincere hope that all is well.


Try the following, replace all your code for this:

Power Query: 
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
 
  If Not Intersect(Destination, Range("J16")) Is Nothing Then
    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) 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
  End If
 
  If Not Intersect(Destination, Range("C6")) Is Nothing Then
      Select Case Destination
          Case Is = "NMORI"
              MsgBox "NMORI - Check full history and 5&2 rule"
          Case Is = "CMORI"
              MsgBox "CMORI - Check full history and 5&2 rule"
          Case Is = "CME"
              MsgBox "CME - Check history and exclusions"
          Case Is = "FMU"
              MsgBox "FMU - Check history and exclusions"
          Case Is = "MHD"
              MsgBox "MHD - Take brief history only"
      End Select
  End If

exitError:
  Application.EnableEvents = True
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​
Click to expand...
Dante, Thanks for this this has solved the problem entirely, many thanks
 
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
174
excel4us
E
M
  • Question Question
Help making my VBA code apply to only one column
Replies
2
Views
513
Alex Blakenburg
A
J
  • Question Question
Multiple select validation list VBA
Replies
1
Views
192
jkpieterse
jkpieterse
K
  • Solved
Combining 3 Worksheet_Change events
Replies
4
Views
493
Kevo
K
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
388
rgree05
R

Forum statistics

Threads
1,223,099
Messages
6,170,109
Members
452,302
Latest member
TaMere

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