put multiple dropdown list selection in rows-CodePudding

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

CodePudding user response：

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

CodePudding user response：

As it is not clear what you mean by "new row" I give you both solutions.

I always recommend to not have the business functionality within the event itself. But instead call a sub whose name is self-explanatory.

You pass the first cell to this sub - in this case it contains the selected value.

Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo err_WorksheetChange

If Not Intersect(Target.Cells(1, 1), Me.Range("L9")) Is Nothing Then
    
    addSelectedValueToEndOfColumn Target.Cells(1, 1) 

    'combineMultipleValuesInOneCell Target.Cells(1, 1) 'uncomment if you want this solution
End If

exit_WorksheetChange:
    Exit Sub

err_WorksheetChange:
    Application.EnableEvents = True

End Sub

addSelectedValueToEndOfColumn first checks if there is a value below the cell with the validation list.

If not: no value was yet selected. Value is inserted below (.offset(1) the current cell.

If yes: the range below the validation cell is checked for the selected value (using application.MATCH). Only if this function returns 0, the new value is added at the end of the list.

Private Sub addSelectedValueToEndOfColumn(c As Range)

If c.Value = "" Then Exit Sub

Application.EnableEvents = False

If c.Offset(1).Value = "" Then  'first selection
    c.Offset(1) = c.Value
Else
    Dim rgCurrentValues As Range
    Set rgCurrentValues = Range(c, c.End(xlDown)).Offset(1)
    With Application    'omitting .worksheetfunction prevents an error due to .match returning nothing
        If .IfError(.Match(c.Value, rgCurrentValues, 0), 0) = 0 Then 'new value
            c.End(xlDown).Offset(1).Value = c.Value
        Else
            'duplicate - don't insert
        End If
    End With
End If
    
c.Value = ""
Application.EnableEvents = True

End Sub

This is the refactored code you provided in your question.

Hopefully a bit more readable than yours :-)

Private Sub combineMultipleValuesInOneCell(c As Range)

If c.Value = "" Then Exit Sub

Dim newValue As String, oldValue As String

Application.EnableEvents = False

newValue = c.Value
Application.Undo
oldValue = c.Value
    
If oldValue = "" Then   'no selection yet
    c.Value = newValue
ElseIf InStr(oldValue, newValue) = 0 Then   'new value not yet selected
    c.Value = oldValue & vbCrLf & newValue
Else    'new value already selected
    c.Value = oldValue
End If
    
Application.EnableEvents = True

End Sub