Programmatically create a multi select drop down list in VBA

[mgCulver]

Hi.

If I create the multiselect list manually, it works fine.

Range("F3").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=Multi"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With

However, if I try to program it, it is not a multi select list.

Can somebody tell me where I am screwing up?

Thanks,

MikeC

Sub MultiSelection
nRow = ActiveCell.Row

Range("F" & nRow).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=Multi"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End Sub


Here are the associated areas:

Private Sub Worksheet_Change(ByVal Target As Range)

' Select Multiple Items from Drop Down List
If ActiveCell.Column = 6 Then
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
If Target.Count > 1 Then GoTo exitHandler 'Target count does not increase with program version.
On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Intersect(Target, rngDV) Is Nothing Then
'do nothing
Else
Application.EnableEvents = False
newVal = Target.Value
Application.Undo
oldVal = Target.Value

Target.Value = newVal

If oldVal = "" Then
'do nothing
Else
If newVal = "" Then
'do nothing
Else
Target.Value = oldVal _
& ", " & newVal
End If
End If
End If


Defined Name "Multi"

Multi
SFA
Commission
AR
AP
Bills
Director Wages
Wage Practice
Consumables
Super
Journaling
Direct Wages
Statements

 

[sijpie]

hi MmgCulver, You have been around now for a bit. So please post your code in between code brackets: press the little VBA icon in the toolbar of the post window, or add manually as shown in red below. You will get a better response to your questions

 

[mgCulver]

hi MmgCulver, You have been around now for a bit. So please post your code in between code brackets: press the little VBA icon in the toolbar of the post window, or add manually as shown in red below. You will get a better response to your questions

Thanks. I finally figured out how to I could do it.

 

[sijpie]

I think you are basically 'screwing up' because of sloppy programming.

• Always declare variables (start the module with Option Explicit to force this)
• Give variables a name which includes at least 1 capital letter. when typing your code don't use the capital letter, VBA should change it automatically. A check for you for typos
• Use indentation with If/Else/Endif, With/End With, Do loops etc.
• When setting Application.EnableEvents to False, make sure you also set it back to True! It is sticky!
• When setting On Error to something else then 0, make sure you set it back to 0 before ending the sub. If an error occurs in another sub it will go back to the error label!
• Minimise the use of On Error. In general it is bad programming other than for a very few occurences
• You don't need to select cells to do something with them. Just use the range and the property. (See modified code below)

Your main error was I think in not enabling events again.

Sheet Code:

Option Explicit

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 GoTo exitHandler 'Target count does not increase with program version.
    ' Select Multiple Items from Drop Down List
    If ActiveCell.Column = 6 Then
        On Error Resume Next
        Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
        On Error GoTo exitHandler
        If rngDV Is Nothing Then GoTo exitHandler
        If Intersect(Target, rngDV) Is Nothing Then
            'do nothing
        Else
            Application.EnableEvents = False
            newVal = Target.Value
            Application.Undo
            oldVal = Target.Value
            
            Target.Value = newVal
            
            If oldVal = "" Then
                'do nothing
            Else
                If newVal = "" Then
                    'do nothing
                Else
                    Target.Value = oldVal _
                    & ", " & newVal
                End If
            End If
        End If
    End If
exitHandler:
    Application.EnableEvents = True
    On Error GoTo 0
End Sub

Module:

Option Explicit



Sub MultiSelection()
    Dim nRow As Long
    
    nRow = ActiveCell.Row
    
    With Range("F" & nRow).Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=Multi"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
End Sub

 

[mgCulver]

I think you are basically 'screwing up' because of sloppy programming.

• Always declare variables (start the module with Option Explicit to force this)
• Give variables a name which includes at least 1 capital letter. when typing your code don't use the capital letter, VBA should change it automatically. A check for you for typos
• Use indentation with If/Else/Endif, With/End With, Do loops etc.
• When setting Application.EnableEvents to False, make sure you also set it back to True! It is sticky!
• When setting On Error to something else then 0, make sure you set it back to 0 before ending the sub. If an error occurs in another sub it will go back to the error label!
• Minimise the use of On Error. In general it is bad programming other than for a very few occurences
• You don't need to select cells to do something with them. Just use the range and the property. (See modified code below)

Your main error was I think in not enabling events again.

Sheet Code:

Option Explicit

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 GoTo exitHandler 'Target count does not increase with program version.
    ' Select Multiple Items from Drop Down List
    If ActiveCell.Column = 6 Then
        On Error Resume Next
        Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
        On Error GoTo exitHandler
        If rngDV Is Nothing Then GoTo exitHandler
        If Intersect(Target, rngDV) Is Nothing Then
            'do nothing
        Else
            Application.EnableEvents = False
            newVal = Target.Value
            Application.Undo
            oldVal = Target.Value
           
            Target.Value = newVal
           
            If oldVal = "" Then
                'do nothing
            Else
                If newVal = "" Then
                    'do nothing
                Else
                    Target.Value = oldVal _
                    & ", " & newVal
                End If
            End If
        End If
    End If
exitHandler:
    Application.EnableEvents = True
    On Error GoTo 0
End Sub

Module:

Option Explicit



Sub MultiSelection()
    Dim nRow As Long
   
    nRow = ActiveCell.Row
   
    With Range("F" & nRow).Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=Multi"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
End Sub

Thanks for your reply. Finally got it to work using activeX Combobox rather than drop down list.

 

[sijpie]

Good. There are always more ways to achieve things . In my test it ran fine with the code above .

 

[mgCulver]

Good. There are always more ways to achieve things . In my test it ran fine with the code above .

Thanks for your help.