Multiple Selection Code

sarahrb1989

New Member
Joined
Dec 15, 2017
Messages
30
I don't know very much about coding or the Excel developer tool. :eek: I have a spreadsheet for work that has demographic information that needs to be input. Currently, I have a combo box using data validation lists that does this for me. Here is the code I currently have in place which changes my selection to a "code". For Example, I choose Male and it changes to M.


Code:
Option Explicit
' Developed by Contextures Inc.
' [URL="http://www.contextures.com"]www.contextures.com[/URL]
Private Sub Combobox2_KeyDown(ByVal _
        KeyCode As MSForms.ReturnInteger, _
        ByVal Shift As Integer)
    'Hide combo box and move to next cell on Enter and Tab
    Select Case KeyCode
        Case 9
            ActiveCell.Offset(0, 1).Activate
        Case 13
            ActiveCell.Offset(1, 0).Activate
        Case Else
            'do nothing
    End Select
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Dim wsList As Worksheet
Set ws = ActiveSheet
Set wsList = Sheets("Demographics Options")
Cancel = True
Set cboTemp = ws.OLEObjects("Combobox2")
  On Error Resume Next
  With cboTemp
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
  End With
On Error GoTo errHandler
  If Target.Validation.Type = 3 Then
    Application.EnableEvents = False
    str = Target.Validation.Formula1
    str = Right(str, Len(str) - 1)
    With cboTemp
      .Visible = True
      .Left = Target.Left
      .Top = Target.Top
      .Width = Target.Width + 15
      .Height = Target.Height + 5
      .ListFillRange = str & "_Codes"
      .LinkedCell = Target.Address
    End With
    cboTemp.Activate
  End If
  
errHandler:
  Application.EnableEvents = True
  Exit Sub
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet
Application.EnableEvents = False
Application.ScreenUpdating = False
If Application.CutCopyMode Then
  'allows copying and pasting on the worksheet
  GoTo errHandler
End If
Set cboTemp = ws.OLEObjects("ComboBox2")
  On Error Resume Next
  With cboTemp
    .Top = 10
    .Left = 10
    .Width = 0
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
    .Object.Value = ""
  End With
errHandler:
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Exit Sub
End Sub
I have one column in the spreadsheet that requires the option of selecting multiple items from the drop down menu and putting them in the same cell together separated by a comma. I have a few different options of code from the same website that do something similar. However, none of these change the item selected to a "code" version.

For example, I choose African American and Caucasian. I would like the cell to read AA, Cauc.

Is there a way to alter any of these codes (including the above) to do this?
:confused:

Here is the sample code for the other options:

http://blog.contextures.com/archives/2014/01/21/multiple-selection-drop-down-with-codes/

Code:
Option Explicit
' Developed by Contextures Inc.
' [URL="http://www.contextures.com"]www.contextures.com[/URL]
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lCode As Long
Dim wsList As Worksheet
Dim rngList As Range
Dim rngListID As Range
If Target.Count > 1 Then GoTo exitHandler
Set wsList = ActiveSheet
Set rngList = wsList.Range("NumWordList")
Set rngListID = wsList.Range("NumWordID")
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 Target.Column = 3 Then
    If oldVal = "" Then
      'do nothing
         lCode = rngListID.Range("A1") _
            .Offset(Application. _
                WorksheetFunction _
                .Match(Target.Value, _
                rngList, 0) - 1, 0)
         Target.Offset(0, 1).Value = lCode
   
   Else
      If newVal = "" Then
        'do nothing
         Target.Offset(0, 1).ClearContents
      Else
         lCode = rngListID.Range("A1") _
            .Offset(Application. _
                WorksheetFunction _
                .Match(Target.Value, _
                rngList, 0) - 1, 0)
         Target.Value = oldVal _
           & ", " & newVal
         Target.Offset(0, 1).Value = Target.Offset(0, 1).Value _
           & ", " & lCode
      End If
    End If
  End If
End If
exitHandler:
  Application.EnableEvents = True
End Sub
http://www.contextures.com/excel-data-validation-multiple.html

Code:
Option Explicit
' Developed by Contextures Inc.
' [URL="http://www.contextures.com"]www.contextures.com[/URL]
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lType As Long
Dim strList As String
Application.EnableEvents = False
On Error Resume Next
   lType = Target.Validation.Type
On Error GoTo exitHandler
If lType = 3 Then
  'if the cell contains a data validation list
   Cancel = True
   strList = Target.Validation.Formula1
   strList = Right(strList, Len(strList) - 1)
   strDVList = strList
   frmDVList.Show
End If
exitHandler:
  Application.EnableEvents = True
 
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim strSep As String
strSep = ", "
  Application.EnableEvents = False
On Error Resume Next
If Target.Count > 1 Then GoTo exitHandler
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
  newVal = Target.Value
  Application.Undo
  oldVal = Target.Value
  Target.Value = newVal
   If newVal = "" Then
      'do nothing
   Else
         If oldVal = "" Then
            Target.Value = newVal
         Else
            Target.Value = oldVal & strSep & newVal
         End If
    End If
End If
exitHandler:
  Application.EnableEvents = True
End Sub
:eek: Please let me know if any additional information is needed. My preference would be to alter the first code for the specific column I need to allow for multiple selections in the same cell that use a "code" version of the selection.
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Try this for your Multi validation list.
NB:- See code "Select Case" items and Abbreviation of those items.
(The items show are the Items within the Validation list.)
Add/delete from code and the validation "list" as required.

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
            [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] newVal
                [COLOR="Navy"]Case[/COLOR] "African American": newVal = "AA"
                [COLOR="Navy"]Case[/COLOR] "Caucasian": newVal = "Cauc"
                [COLOR="Navy"]Case[/COLOR] "Male": newVal = "M"
                [COLOR="Navy"]Case[/COLOR] "Female": newVal = "FM"
            [COLOR="Navy"]End[/COLOR] Select
            
            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
 

sarahrb1989

New Member
Joined
Dec 15, 2017
Messages
30
Unfortunately it did not work. I have no problem getting the combobox to use the data validation list and change my selection to an abbreviated version. The main problem is I can't choose multiple items and put them in the same cell separated by a comma.
 

sarahrb1989

New Member
Joined
Dec 15, 2017
Messages
30
Thank you for sending the example file. This is exactly what I need. Is it possible I am putting the code in the wrong location? The worksheet I'm using has some code in it already. Do I tack it onto the code I already have or create a separate sheet or module for it? Please let me know.


I'm not sure why its not working for you, Have a look at the attached Example file.
Hopefully it will resolve your problem.
https://app.box.com/s/wa8ixnidqz9hw7k1mcfuzzm8xjbh545f
 

sarahrb1989

New Member
Joined
Dec 15, 2017
Messages
30
I am also not sure where you change the validation list in the code. Could you highlight the code that I need to change to the named validation list?
 

sarahrb1989

New Member
Joined
Dec 15, 2017
Messages
30
I am also not sure where you change the validation list in the code. Could you highlight the code that I need to change to the named validation list?
Could you check this and let me know if it is correct?

Code:
Application.EnableEvents = False
            [COLOR=#FF8C00]newVal = disability_types_codes[/COLOR]
            Select Case newVal
                Case "Difficulty Seeing": newVal = "DS"
                Case "Difficulty Hearing": newVal = "DH"
                Case "Difficulty Having Speech Understood": newVal = "HSU"
                Case "Learning Disability": newVal = "LD"
                Case "Developmental Disability": newVal = "DD"
                Case "Dementia": newVal = "Dem"
                Case "Autism": newVal = "Aut"
                Case "Physical/Mobility": newVal = "Phys/Mob"
                Case "Chronic Physical Health Condition": newVal = "CHC"
                Case "Chronic Mental Health Condition": newVal = "CMH"
                Case "Other": newVal = "Oth"
                Case "No Disability": newVal = "ND"
                Case "Declined to Answer": newVal = "DTA"
            End Select
            
            Application.Undo
            [COLOR=#FF8C00]oldVal = disability_types[/COLOR]
            Target.Value = newVal
 

sarahrb1989

New Member
Joined
Dec 15, 2017
Messages
30
It is trying to work but says I need to change the highlighted code. See below.

Code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim Rng As Range
Dim Dn As Range
If Target.Count = 1 Then
On Error Resume Next
With Sheets("Demographics Options") 'Change Date sheet here as required
        Set Rng = .Range("R2", .Range("R" & Rows.Count).End(xlUp))
    End With
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
If rngDV Is Nothing Then Exit Sub
    If Not Intersect(Target, rngDV) Is Nothing Then
        Application.EnableEvents = False
           For Each Dn In Rng
                If Dn.Value = Target.Value Then
                    newVal = Dn.Offset(, 1).Value
                    Exit For
                End If
           Next Dn
            Application.Undo
            oldVal = Target.Value
            Target.Value = newVal
                If Not newVal = "" Then
                    Ta[COLOR=#FF8C00]rget.Value = If(oldVal = "", newVal, oldVal & ", " & newVal)[/COLOR]
                End If
    End If
Application.EnableEvents = True
End If
End Sub
 

Forum statistics

Threads
1,081,703
Messages
5,360,747
Members
400,595
Latest member
T_Dubs

Some videos you may like

This Week's Hot Topics

  • VBA (Userform)
    Hi All, I just would like to know why my code isn't working. Here is my VBA code: [CODE=vba]Private Sub OKButton_Click() Dim i As Integer...
  • List box that changes fill color
    Hello, I have gone through so many pages trying to figure this out. I have a 2020 calendar that depending on the day needs to have a certain...
  • Remove duplicates and retain one. Cross-linked cases
    Hi all I ran out of google keywords to use and still couldn't find a reference how to achieve the results of a single count. It would be great if...
  • VBA Copy and Paste With Duplicates
    Hello All, I'm in need of some input. My VBA skills are sub-par at best. I've assembled this code from basic research and it works but is...
  • Macro
    is it possible for a macro to run if the active cell value is different to the value above it
  • IF DATE and TIME
    I currently use this to check if date has passed but i also need to set a time on it too. Is it possible? [CODE=vba]=IF(B:B>TODAY(),"Not...
Top