multi-select- tried macro but does not work

emergencyrn

New Member
Joined
May 15, 2013
Messages
21
Hello-

I would like to multi-select from a data-validation list. I found a macro on line which works well. But the note to the macro says that if you save the document, the macro will not work upon opening. I tried it anyway and it did work but it does not stay. If anyone can help, it would be much appreciated. If I cannot multi-select from 4 options to make combinations, i will be forced to list all possible combos in the list and I have several lists that have multi-select needs. If this can be done without a macro that would be great. I have seen posts that state mark the list multi-select but I cannot see that function in excel 2016.Here is the macro that would not save when the document is closed.



Private Sub Worksheet_Change(ByVal Target As Range)
'Code by Sumit Bansal from https://trumpexcel.com
' To Select Multiple Items from a Drop Down List in Excel
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Target.Address = "$C$2" 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 & ", " & Newvalue
Else:
Target.Value = Oldvalue
End If
End If
End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Try this:-
Use on any cell with validation list

Code:
Private [COLOR=navy]Sub[/COLOR] Worksheet_Change(ByVal Target [COLOR=navy]As[/COLOR] Range)
[COLOR=navy]Dim[/COLOR] rngDV [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] oldVal [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] newVal [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]If[/COLOR] Target.Count = 1 [COLOR=navy]Then[/COLOR]
[COLOR=navy]On[/COLOR] [COLOR=navy]Error[/COLOR] [COLOR=navy]Resume[/COLOR] [COLOR=navy]Next[/COLOR]
[COLOR=navy]Set[/COLOR] rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
[COLOR=navy]If[/COLOR] rngDV [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR] [COLOR=navy]Exit[/COLOR] [COLOR=navy]Sub[/COLOR]
    [COLOR=navy]If[/COLOR] Not Intersect(Target, rngDV) [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
        Application.EnableEvents = False
            newVal = Target.Value
            Application.Undo
            oldVal = Target.Value
            Target.Value = newVal
                [COLOR=navy]If[/COLOR] Not newVal = "" [COLOR=navy]Then[/COLOR]
                    Target.Value = IIf(oldVal = "", newVal, oldVal & ", " & newVal)
                [COLOR=navy]End[/COLOR] If
    [COLOR=navy]End[/COLOR] If
Application.EnableEvents = True
[COLOR=navy]End[/COLOR] [COLOR=navy]If[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0
Thank you. I will give it a try.

Try this:-
Use on any cell with validation list

Code:
Private [COLOR=navy]Sub[/COLOR] Worksheet_Change(ByVal Target [COLOR=navy]As[/COLOR] Range)
[COLOR=navy]Dim[/COLOR] rngDV [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] oldVal [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] newVal [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]If[/COLOR] Target.Count = 1 [COLOR=navy]Then[/COLOR]
[COLOR=navy]On[/COLOR] [COLOR=navy]Error[/COLOR] [COLOR=navy]Resume[/COLOR] [COLOR=navy]Next[/COLOR]
[COLOR=navy]Set[/COLOR] rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
[COLOR=navy]If[/COLOR] rngDV [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR] [COLOR=navy]Exit[/COLOR] [COLOR=navy]Sub[/COLOR]
    [COLOR=navy]If[/COLOR] Not Intersect(Target, rngDV) [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
        Application.EnableEvents = False
            newVal = Target.Value
            Application.Undo
            oldVal = Target.Value
            Target.Value = newVal
                [COLOR=navy]If[/COLOR] Not newVal = "" [COLOR=navy]Then[/COLOR]
                    Target.Value = IIf(oldVal = "", newVal, oldVal & ", " & newVal)
                [COLOR=navy]End[/COLOR] If
    [COLOR=navy]End[/COLOR] If
Application.EnableEvents = True
[COLOR=navy]End[/COLOR] [COLOR=navy]If[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Upvote 0
One more question, the person using this database is not an excel guru. Is there a way to modify this so that it allows an un-select if they enter an incorrect choice... Sorry thinking ahead.
 
Upvote 0
Try this complete code with a new "Worksheet_BeforeRightClick".
This allows the user to remove the present data in the target cell, in order to start again, by right clicking the target cell.
Although the could achieve the same thing by clicking "Delete"

Perhaps you meant to just remove the last Entry, that a lot harder !!!!

Code:
Option Explicit
Dim Rng As Range
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim nstr As String, Sp As Variant, n As Long
If Not Rng Is Nothing Then
    If Target.Address = Rng.Address Then
        Cancel = True
        Target = ""
    End If
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
If Target.Count = 1 Then
On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
If rngDV Is Nothing Then Exit Sub
    Set Rng = Target 'NB:- Extra Line
    If Not Intersect(Target, rngDV) Is Nothing Then
        Application.EnableEvents = False
            newVal = Target.Value
            Application.Undo
            oldVal = Target.Value
            Target.Value = newVal
                If Not newVal = "" Then
                    Target.Value = IIf(oldVal = "", newVal, oldVal & ", " & newVal)
                End If
    End If
Application.EnableEvents = True
End If
End Sub
 
Upvote 0
To remove just the last entry in target cell.
Replace the entire code as below:-

Code:
Option Explicit
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Fd [COLOR="Navy"]As[/COLOR] Boolean
Private [COLOR="Navy"]Sub[/COLOR] Worksheet_BeforeRightClick(ByVal Target [COLOR="Navy"]As[/COLOR] Range, Cancel [COLOR="Navy"]As[/COLOR] Boolean)
[COLOR="Navy"]Dim[/COLOR] nstr [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]If[/COLOR] Not Rng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]If[/COLOR] Target.Address = Rng.Address [COLOR="Navy"]Then[/COLOR]
        Fd = True
        Cancel = True
        Sp = Split(Rng, ", ")
        [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp) - 1
            nstr = nstr & IIf(nstr = "", Sp(n), ", " & Sp(n))
        [COLOR="Navy"]Next[/COLOR] n
        Target = "": Target = nstr
        Fd = False
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Private [COLOR="Navy"]Sub[/COLOR] Worksheet_Change(ByVal Target [COLOR="Navy"]As[/COLOR] Range)
[COLOR="Navy"]Dim[/COLOR] rngDV [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] oldVal [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] newVal [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]If[/COLOR] Target.Count = 1 And Not Fd [COLOR="Navy"]Then[/COLOR]
[COLOR="Navy"]On[/COLOR] [COLOR="Navy"]Error[/COLOR] [COLOR="Navy"]Resume[/COLOR] [COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Set[/COLOR] rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
[COLOR="Navy"]If[/COLOR] rngDV [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Exit[/COLOR] [COLOR="Navy"]Sub[/COLOR]
    Set Rng = Target '[COLOR="Green"][B]NB:- Extra Line[/B][/COLOR]
    [COLOR="Navy"]If[/COLOR] Not Intersect(Target, rngDV) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
        Application.EnableEvents = False
            newVal = Target.Value
            Application.Undo
            oldVal = Target.Value
            Target.Value = newVal
                [COLOR="Navy"]If[/COLOR] Not newVal = "" [COLOR="Navy"]Then[/COLOR]
                    Target.Value = IIf(oldVal = "", newVal, oldVal & ", " & newVal)
                [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
Application.EnableEvents = True
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Thank you. I will try both and see which is most likely to be used. Now I just need my admit to enable macros in our shared folder. Works great on my desktop but is locked out on the shared drive.... **** security.

To remove just the last entry in target cell.
Replace the entire code as below:-

Code:
Option Explicit
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Fd [COLOR=Navy]As[/COLOR] Boolean
Private [COLOR=Navy]Sub[/COLOR] Worksheet_BeforeRightClick(ByVal Target [COLOR=Navy]As[/COLOR] Range, Cancel [COLOR=Navy]As[/COLOR] Boolean)
[COLOR=Navy]Dim[/COLOR] nstr [COLOR=Navy]As[/COLOR] [COLOR=Navy]String,[/COLOR] Sp [COLOR=Navy]As[/COLOR] Variant, n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]If[/COLOR] Not Rng [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR]
    [COLOR=Navy]If[/COLOR] Target.Address = Rng.Address [COLOR=Navy]Then[/COLOR]
        Fd = True
        Cancel = True
        Sp = Split(Rng, ", ")
        [COLOR=Navy]For[/COLOR] n = 0 To UBound(Sp) - 1
            nstr = nstr & IIf(nstr = "", Sp(n), ", " & Sp(n))
        [COLOR=Navy]Next[/COLOR] n
        Target = "": Target = nstr
        Fd = False
    [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]End[/COLOR] If
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Private [COLOR=Navy]Sub[/COLOR] Worksheet_Change(ByVal Target [COLOR=Navy]As[/COLOR] Range)
[COLOR=Navy]Dim[/COLOR] rngDV [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] oldVal [COLOR=Navy]As[/COLOR] [COLOR=Navy]String[/COLOR]
[COLOR=Navy]Dim[/COLOR] newVal [COLOR=Navy]As[/COLOR] [COLOR=Navy]String[/COLOR]
[COLOR=Navy]If[/COLOR] Target.Count = 1 And Not Fd [COLOR=Navy]Then[/COLOR]
[COLOR=Navy]On[/COLOR] [COLOR=Navy]Error[/COLOR] [COLOR=Navy]Resume[/COLOR] [COLOR=Navy]Next[/COLOR]
[COLOR=Navy]Set[/COLOR] rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
[COLOR=Navy]If[/COLOR] rngDV [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR] [COLOR=Navy]Exit[/COLOR] [COLOR=Navy]Sub[/COLOR]
    Set Rng = Target '[COLOR=Green][B]NB:- Extra Line[/B][/COLOR]
    [COLOR=Navy]If[/COLOR] Not Intersect(Target, rngDV) [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR]
        Application.EnableEvents = False
            newVal = Target.Value
            Application.Undo
            oldVal = Target.Value
            Target.Value = newVal
                [COLOR=Navy]If[/COLOR] Not newVal = "" [COLOR=Navy]Then[/COLOR]
                    Target.Value = IIf(oldVal = "", newVal, oldVal & ", " & newVal)
                [COLOR=Navy]End[/COLOR] If
    [COLOR=Navy]End[/COLOR] If
Application.EnableEvents = True
[COLOR=Navy]End[/COLOR] If
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Regards Mick
 
Upvote 0
I have another question dealing with this multiselect.

I am now trying to conditional format another cell based on the multiselect cell response. For example, A1= A,B (mulitselect options). I want cell b1 to turn a certain color if the cell contains A or B or AB. I cannot use the contains formatting so I have to use the formula formatting but it does not recognize a multiselect answer. I did a formula if A1=A (works), so does B but A, B mulitsect answer is not recognized. I even tried formula if cell contains A or B but nothing works. Looking for help. Hope this makes sense.
 
Upvote 0

Forum statistics

Threads
1,223,903
Messages
6,175,284
Members
452,630
Latest member
OdubiYouth

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