multi-select- tried macro but does not work

[emergencyrn]

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

 

[MickG]

Try this:-
Use on any cell with validation list

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

 

[emergencyrn]

Thank you. I will give it a try.

Try this:-
Use on any cell with validation list

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

 

[emergencyrn]

OMG this works perfectly. Thank you. I am doing my happy dance.....

 

[MickG]

You're welcome

 

[emergencyrn]

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.

 

[MickG]

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

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

 

[MickG]

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

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

 

[emergencyrn]

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

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

 

[emergencyrn]

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.