mdkusername
New Member
- Joined
- Dec 9, 2015
- Messages
- 34
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
This is the list box VBA
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: