put multiple dropdown list selection in rows

Question

I have the following VBA code that will allow me to select multiple values from a dropdown list. When I select an item from the list it puts it in a new line in one cell. I wanted to have every items I select from the list in a new row. How can I tweak the code?

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

Answer 1

A Worksheet Change: Write Multiple Lines to Cells

• It is assumed that the destination cells are adjacent to the bottom (see RowOffset and ColumnOffset) of the validation cells.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Const Delimiter As String = vbLf
    Const RowOffset As Long = 1
    Const ColumnOffset As Long = 0
    Const RemoveExisting As Boolean = True
    
    ' Attempt to reference all cells containing data validation ('vrg').
    Dim vrg As Range
    On Error Resume Next
        Set vrg = Me.UsedRange.SpecialCells(xlCellTypeAllValidation)
    On Error GoTo 0
    If vrg Is Nothing Then Exit Sub
    
    ' Attempt to reference the cells containing data validation
    ' that have changed.
    Dim trg As Range
    On Error Resume Next
        Set trg = Intersect(Target, vrg)
    On Error GoTo 0
    If trg Is Nothing Then Exit Sub
    
    ' Disable events before writing to not retrigger the code.
    Application.EnableEvents = False
    
    Dim tCell As Range
    Dim tString As String
    Dim tStringFound As Boolean
    
    Dim dCell As Range
    Dim dSubStrings() As String
    Dim dSubString As Variant
    Dim dString As String
    Dim dn As Long
    Dim dnUpper As Long
    
    ' If the current target string ('tString') is not equal to any lines
    ' in the destination cell, add the current target string
    ' to a new line in the destination cell.
    For Each tCell In trg.Cells
        tString = CStr(tCell.Value)
        Set dCell = tCell.Offset(RowOffset, ColumnOffset)
        dString = CStr(dCell.Value)
        If Len(tString) > 0 Then
            If Len(dString) = 0 Then
                dCell.Value = tString
            Else
                dSubStrings = Split(dString, Delimiter)
                dnUpper = UBound(dSubStrings)
                For dn = 0 To dnUpper
                    If StrComp(dSubStrings(dn), tString, vbTextCompare) = 0 Then
                        Exit For
                    End If
                Next dn
                If dn <= dnUpper Then ' target string found
                    If RemoveExisting Then
                        If dnUpper = 0 Then
                            dCell.Value = vbNullString
                        Else
                            For dn = dn To dnUpper - 1
                                dSubStrings(dn) = dSubStrings(dn + 1)
                            Next dn
                            ReDim Preserve dSubStrings(0 To dnUpper - 1)
                            dCell.Value = Join(dSubStrings, Delimiter)
                        End If
                    'Else ' do not remove existing target string
                    End If
                Else ' target string not found
                    dCell.Value = dString & Delimiter & tString
                End If
            End If
        End If
    Next tCell
    
    ' Enable events before exiting.
    Application.EnableEvents = True

End Sub