multi-select- tried macro but does not work

E

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
 
Sort by date Sort by votes
Try this amalgamated code:-
NB:-
This entire "Event code" will AllowMulti Entries in any validation cell, It will also allow deselection of entries one by one using the Right Click Event. The code will also allow cell "B1" to turn red when either an"A" or "B" or "A,B" is inthe selection and will change the colour back on deselection of "A" Or "B".


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
Call col(Target)
[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
Call col(Target)
Application.EnableEvents = True
[COLOR=navy]End[/COLOR] If
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
[COLOR=navy]

Sub[/COLOR] col(Tar [COLOR=navy]As[/COLOR] Object)
[COLOR=navy]Dim[/COLOR] Sp [COLOR=navy]As[/COLOR] Variant, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
Sp = Split(Tar.Value, ", ")
Range("B1").Interior.Color = xlNone
[COLOR=navy]For[/COLOR] n = 0 To UBound(Sp)
    [COLOR=navy]Select[/COLOR] [COLOR=navy]Case[/COLOR] Sp(n)
        [COLOR=navy]Case[/COLOR] "A", "B": Range("B1").Interior.Color = vbRed
    [COLOR=navy]End[/COLOR] Select
[COLOR=navy]Next[/COLOR] n
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Thank you I will give it a try...


MickG said:
Try this amalgamated code:-
NB:-
This entire "Event code" will AllowMulti Entries in any validation cell, It will also allow deselection of entries one by one using the Right Click Event. The code will also allow cell "B1" to turn red when either an"A" or "B" or "A,B" is inthe selection and will change the colour back on deselection of "A" Or "B".


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
Call col(Target)
[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
Call col(Target)
Application.EnableEvents = True
[COLOR=navy]End[/COLOR] If
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
[COLOR=navy]

Sub[/COLOR] col(Tar [COLOR=navy]As[/COLOR] Object)
[COLOR=navy]Dim[/COLOR] Sp [COLOR=navy]As[/COLOR] Variant, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
Sp = Split(Tar.Value, ", ")
Range("B1").Interior.Color = xlNone
[COLOR=navy]For[/COLOR] n = 0 To UBound(Sp)
    [COLOR=navy]Select[/COLOR] [COLOR=navy]Case[/COLOR] Sp(n)
        [COLOR=navy]Case[/COLOR] "A", "B": Range("B1").Interior.Color = vbRed
    [COLOR=navy]End[/COLOR] Select
[COLOR=navy]Next[/COLOR] n
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
Trying to apply 2 Worksheet Changes
Replies
1
Views
165
Joe4
Joe4
H
  • Question Question
Using VBA to select multiple criteria in 2 dropdown lists on the same sheet
Replies
1
Views
415
My Aswer Is This
My Aswer Is This
S
  • Question Question
VBA code for Multiple selections in dropdown list
Replies
1
Views
479
Artik
Artik
welshraz
  • Question Question
VBA - Restrict Code to One Column for Multi-choice Dropdown
Replies
2
Views
81
welshraz
welshraz
D
  • Solved
VBA to deselect a single value in a multi-selection drop down list.
Replies
1
Views
823
smozgur
smozgur

Forum statistics

Threads
1,223,911
Messages
6,175,323
Members
452,635
Latest member
laura12345

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