Multiple Selection Code

[sarahrb1989]

I don't know very much about coding or the Excel developer tool. 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.

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?

Here is the sample code for the other options:

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

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

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

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]

You're welcome