Can you combine these 2 macros ?

E

excel4us

New Member
Joined
Sep 29, 2024
Messages
4
Office Version
  1. 365
Platform
  1. Windows
First macro allow to choose multiple items in same cell from drop down list. Second macro enables date picker - mini calendar if the cell is in date format.

I am trying to use these macros in the same sheet.

First Macro code

VBA Code: 
Option ExplicitPrivate Sub Worksheet_Change(ByVal Destination As Range)Dim rngDropdown As RangeDim oldValue As StringDim newValue As StringDim DelimiterType As StringDelimiterType = ", "Dim DelimiterCount As IntegerDim TargetType As IntegerDim i As IntegerDim arr() As String If Destination.Count > 1 Then Exit SubOn 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 = TrueEnd Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) End Sub

Second marco

VBA Code: 
'Put this procedure in your Worksheet's in the Microsoft Excel Objects folderPrivate Sub Worksheet_SelectionChange(ByVal Target As Range)        ' Check if Active Cell format matches the "Short Date" number format    If ActiveCell.NumberFormat = "m/d/yyyy" Then        ' If the Active Cell format is a date, make the calendar visible        ActiveSheet.Shapes("Calendar").Visible = True                ' Change the position of the calendar to be just below and to the right of the Active Cell        ActiveSheet.Shapes("Calendar").Left = ActiveCell.Left + ActiveCell.Width        ActiveSheet.Shapes("Calendar").Top = ActiveCell.Top + ActiveCell.Height        ' If the Active Cell isn't a date, make the calendar invisible    Else: ActiveSheet.Shapes("Calendar").Visible = False        End IfEnd Sub
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Sort by date Sort by votes
Welcome to the Board!

Did you try posting your code from a phone? They are coming over as one, long text string, making your code pretty much unreadable.
Can you try posting the code again, maybe from a PC?
 
Upvote 0
The second one is short enough to check it
and I thing that processing shall start with that one, so one code for both actions could be

VBA Code: 
Option Explicit

'Put this procedure in your Worksheet's in the Microsoft Excel Objects folder
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Check if Active Cell format matches the "Short Date" number format    
If ActiveCell.NumberFormat = "m/d/yyyy" Then        
' If the Active Cell format is a date, make the calendar visible        
  ActiveSheet.Shapes("Calendar").Visible = True                
' Change the position of the calendar to be just below and to the right of the Active Cell          
  ActiveSheet.Shapes("Calendar").Left = ActiveCell.Left + ActiveCell.Width        
  ActiveSheet.Shapes("Calendar").Top = ActiveCell.Top + ActiveCell.Height        
' If the Active Cell isn't a date, make the calendar invisible    
Else: ActiveSheet.Shapes("Calendar").Visible = False        
End If
'note that final End Sub from second procedure was deleted 

'note that I used Option explicit already avbove
'here starts the code from the first procedure but without option ... and private sub ... lines
Dim rngDropdown As Range
Dim oldValue As String
Dim newValue As String
Dim DelimiterType As StringDelimiterType = ", "
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 
'... and the rest of the code of first procedure including final End Sub

So try it and if it works then fine, if not - use the tip by @Joe4 and post both codes in standard form (with line breaks)
 
Upvote 0
Hi,

@Kaper Thank you for the suggestion, but the procedure isn't working. So I am posting both the codes here.

Can we use both these macros in the same sheet ?

The code for 1st Macro is also available in the link here, refer to the section - Multi-selection dropdown with item removal

Multiple selection dropdown - VBA​

The code for 1st Macro
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[/B]
 
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


The code for 2nd Macro is here.

VBA Code: 
'Put this procedure in your Worksheet's in the Microsoft Excel Objects folder
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
    ' Check if Active Cell format matches the "Short Date" number format
    If ActiveCell.NumberFormat = "m/d/yyyy" Then
        ' If the Active Cell format is a date, make the calendar visible
        ActiveSheet.Shapes("Calendar").Visible = True
       
        ' Change the position of the calendar to be just below and to the right of the Active Cell
        ActiveSheet.Shapes("Calendar").Left = ActiveCell.Left + ActiveCell.Width
        ActiveSheet.Shapes("Calendar").Top = ActiveCell.Top + ActiveCell.Height
   
    ' If the Active Cell isn't a date, make the calendar invisible
    Else: ActiveSheet.Shapes("Calendar").Visible = False
   
    End If

End Sub
 
Last edited by a moderator:
Upvote 0
Well, it's much better visible now

Both macros react to different events - first one is for the change in value of the cell, the second is for changing selected cell.

In the listing of first macro, at the end there is an empty Selection Change event handler (macro).

VBA Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
End Sub

Replace it with the code presented in the second one. And if each of them worked fine alone, I'd expect they also work fine together in the same sheet.

So the code to be pasted in Sheet code (right click on a sheet tab and select View code) shall be:


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[/B]
 
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)
   
    ' Check if Active Cell format matches the "Short Date" number format
    If ActiveCell.NumberFormat = "m/d/yyyy" Then
        ' If the Active Cell format is a date, make the calendar visible
        ActiveSheet.Shapes("Calendar").Visible = True
       
        ' Change the position of the calendar to be just below and to the right of the Active Cell
        ActiveSheet.Shapes("Calendar").Left = ActiveCell.Left + ActiveCell.Width
        ActiveSheet.Shapes("Calendar").Top = ActiveCell.Top + ActiveCell.Height
   
    ' If the Active Cell isn't a date, make the calendar invisible
    Else: ActiveSheet.Shapes("Calendar").Visible = False
   
    End If

End Sub
 
Upvote 0
@ Kaper - Thank you for the reply.

I tried like you said replacing the empty one at end of 1st macro with the code from the 2nd macro.

1st Macro did not work but the 2nd Macro worked. I didn't get any error message.

You can check this video link here, Screen sharing with 2 Macros .

Can these 2 macros work in combination in the same sheet?

1st Macro - Add multiple items from Drop down list in the same cell

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

2nd Macro ; I have addin 'Mini Calender' saved as Excel Object in same name "Calendar" as shown in the code for this macro to work.


VBA Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    ' Check if Active Cell format matches the "Short Date" number format
    If ActiveCell.NumberFormat = "m/d/yyyy" Then
        ' If the Active Cell format is a date, make the calendar visible
        ActiveSheet.Shapes("Calendar").Visible = True
        
        ' Change the position of the calendar to be just below and to the right of the Active Cell
        ActiveSheet.Shapes("Calendar").Left = ActiveCell.Left + ActiveCell.Width
        ActiveSheet.Shapes("Calendar").Top = ActiveCell.Top + ActiveCell.Height
    
    ' If the Active Cell isn't a date, make the calendar invisible
    Else: ActiveSheet.Shapes("Calendar").Visible = False
    
    End If

End Sub
 
Upvote 0
Hi

I couldn't find a solution for the above case? Please provide some suggestions.
 
Upvote 0
You must log in or register to reply here.

Similar threads

welshraz
  • Question Question
VBA - Restrict Code to One Column for Multi-choice Dropdown
Replies
2
Views
123
welshraz
welshraz
M
  • Question Question
Help making my VBA code apply to only one column
Replies
2
Views
593
Alex Blakenburg
A
J
  • Question Question
Multiple select validation list VBA
Replies
1
Views
216
jkpieterse
jkpieterse
K
  • Solved
Combining 3 Worksheet_Change events
Replies
4
Views
540
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
396
rgree05
R

Forum statistics

Threads
1,224,739
Messages
6,180,674
Members
452,993
Latest member
FDARYABEE

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