Multi select list box selections replace anything in the target cell

mdkusername

New Member
Joined
Dec 9, 2015
Messages
26
I have a worksheet with cells that are populated by a multi-select list box. I would like the list box selections to replace anything already in the cell, and also not allow any duplicate list box selections in the cell.

This is the VBA for the worksheet
VBA Code:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim strList As String
On Error Resume Next
Application.EnableEvents = False

   Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
   On Error GoTo exitHandler

   If rngDV Is Nothing Then GoTo exitHandler

   If Not Intersect(target, rngDV) Is Nothing Then
      If target.Validation.Type = 3 Then

         strList = target.Validation.Formula1
         strList = Right(strList, Len(strList) - 1)
         strDVList = strList
         frmDVList.Show
      End If
   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

Private Sub RemoveQuotes(ByVal filename As String, ByVal target As ListBox)
        '  A StreamReader to fetch the data
        Dim sr As New IO.StreamReader(filename)
        '  A string to hold each line as it is read
        Dim line As String = String.Empty

        ' Read from the file
        ' As long as there is something left to read
        Do While sr.Peek <> -1
            ' Replace the Quotation Marks with Nothing
            line = sr.ReadLine.Replace("""", "")

            ' Add edited text to a ListBox
            target.Items.Add (line)
        Loop

        '  Tidy up when finished
        sr.Close()
        sr = Nothing
End Sub

Public Sub TextNoModification()
        Const DELIMITER As String = "," 'or "|", vbTab, etc.
        Dim myRecord As Range
        Dim myField As Range
        Dim nFileNum As Long
        Dim sOut As String
       
        nFileNum = FreeFile
        Open "Test.txt" For Output As #nFileNum
        For Each myRecord In Range("A1:A" & _
                Range("A" & Rows.Count).End(xlUp).Row)
            With myRecord
                For Each myField In Range(.Cells(1), _
                        Cells(.Row, Columns.Count).End(xlToLeft))
                    sOut = sOut & DELIMITER & myField.Text
                Next myField
                Print #nFileNum, Mid(sOut, 2)
                sOut = Empty
            End With
        Next myRecord
        Close #nFileNum
    End Sub

This is the list box VBA
VBA Code:
Option Explicit
Private Sub cmdAdd_Click()
On Error GoTo errHandler
Dim lCountList As Long

With Me.lstDV
  For lCountList = 0 To .ListCount - 1
    If CStr(.List(lCountList)) = Me.cboDV.Value Then
      On Error GoTo errHandler
      .Selected(lCountList) = True
      Exit For
    End If
  Next lCountList
End With

Me.cboDV.Value = ""
Me.cboDV.SetFocus

exitHandler:
    Exit Sub
   
errHandler:
    MsgBox "Could not select all items"
    Resume exitHandler

End Sub

Private Sub cmdClose_Click()
  Unload Me
End Sub

Private Sub cmdOK_Click()
Dim strSelItems As String
Dim lCountList As Long
Dim strSep As String
Dim strAdd As String
Dim bDup As Boolean

On Error Resume Next
strSep = vbNewLine

With Me.lstDV
   For lCountList = 0 To .ListCount - 1
     
      If .Selected(lCountList) Then
         strAdd = .List(lCountList)
      Else
         strAdd = ""
      End If
     
      If strSelItems = "" Then
         strSelItems = strAdd
      Else
         If strAdd <> "" Then
            strSelItems = strSelItems & strSep & strAdd
         End If
      End If
  
   Next lCountList
End With

With ActiveCell
   If .Value <> "" Then
      .Value = ActiveCell.Value & strSep & strSelItems
   Else
      .Value = strSelItems
   End If
End With

Unload Me

End Sub


Private Sub lstDV_Click()

End Sub

Private Sub UserForm_Initialize()
Me.lstDV.RowSource = strDVList
Me.cboDV.RowSource = strDVList
End Sub
Private Sub UserForm_Activate()

    Me.StartUpPosition = 0
    Me.Top = Application.Top + 100
    Me.Left = Application.Left + Application.Width - Me.Width - 200

End Sub
 
Last edited by a moderator:

Some videos you may like

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".

Watch MrExcel Video

Forum statistics

Threads
1,128,158
Messages
5,629,032
Members
416,362
Latest member
Cocito

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top