VBA code to have each values selected from a multiselect dependent dropdown list in excel cell in se-CodePudding

I have created a multi-select dependent dropdown list in excel. When I select from the multi-select list, I could have every selected value in a single cell in a new line. However, I wanted to put each selection in an adjacent separate cell instead of cramming the values in one cell. For instance, when I select Male and Female from my dropdown list, I want Male to appear on the first cell and Female on the next cell below. I want to apply the code to only one column with the multi-select dropdown list. Does anyone have that code?

The code I am using currently is below:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Not Intersect(Target, Range("L9")) Is Nothing 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 & vbNewLine & Newvalue
      Else:
        Target.Value = Oldvalue
      End If
    End If
  End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub

CodePudding user response：

Please, test the next updated event:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Oldvalue As String, Newvalue As String, lastRM As Long, mtch
'Application.EnableEvents = True 'useless code line
On Error GoTo Exitsub
If Not Intersect(Target, Range("L9")) Is Nothing Then
  If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
    GoTo Exitsub
  Else
        If Target.Value = "" Then
             Me.Range(Target.Offset(, 1), Target.Offset(, 1).End(xlDown)).ClearContents
             GoTo Exitsub
        Else
            Application.EnableEvents = False
            lastRM = Target.Offset(, 1).End(xlDown).row
            If lastRM = Me.rows.count Then
                If Target.Offset(, 1).Value <> "" Then
                      If Target.Offset(, 1).Value <> Target.Value Then
                            Target.Offset(1, 1).Value = Target.Value
                      End If
                Else
                    Target.Offset(, 1) = Target.Value
                End If
            Else
                mtch = Application.match(Target.Value, Me.Range(Target.Offset(, 1), Target.Offset(, 1).End(xlDown)), 0)
                If IsError(mtch) Then
                    Target.Offset(lastRM - Target.row   1, 1) = Target.Value
                End If
            End If
          End If
  End If
End If
'Application.EnableEvents = True 'useless code line
Exitsub:
 Application.EnableEvents = True
End Sub

Edited:

Please, test the next version, which will do what you required in your last comment (to return in column L:L, starting from L9, inclusive):




Private Sub Worksheet_Change(ByVal Target As Range)
 Dim Oldvalue As String, Newvalue As String, lastRM As Long, mtch

 Application.Calculation = xlCalculationManual
 On Error GoTo Exitsub
 If Not Intersect(Target, Range("L9")) Is Nothing Then
    If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
          GoTo Exitsub
    Else
          Application.EnableEvents = False
          If Target.Value = "" Then
               Me.Range(Target.Offset(1), Target.Offset(1).End(xlDown)).ClearContents
               GoTo Exitsub
          Else
               Newvalue = Target.Value
               Application.Undo
               Oldvalue = Target.Value
               lastRM = Target.End(xlDown).row
               If lastRM = Me.rows.count Then
                      If Oldvalue <> "" Then
                           Target.Offset(1).Value = Newvalue
                      End If
               Else
                      mtch = Application.match(Newvalue, Me.Range(Target, Target.End(xlDown)), 0)
                      If IsError(mtch) Then
                          Target.Offset(lastRM - Target.row   1) = Newvalue
                      End If
              End If
              If Oldvalue <> "" Then
                    Target.Value = Oldvalue
              Else
                    Target.Value = Newvalue
              End If
          End If
    End If
 End If
 Application.Calculation = xlCalculationAutomatic
Exitsub:
  Application.EnableEvents = True
End Sub

Please, send some feedback after testing it.