ControlSource = Wokrsheet for ListBox

[gheyman]

I have a ListBox set to allow multiselections (1-fmMultiSelectMulti). I want all the selections to be listed on a Worksheet (Worksheets("ETC")) My BoundColumn is set to 5.

I have this code that someone was nice enough to send me a long time ago. It works with the exception that it is pasting the values from column1 in my ListBox, not column5 as I set the BoundColumn to.
It is also doing something else I cannot figure out. It will not paste duplicate values on the sheet even if they are selected. - This is more a curiosity than a problem

Private Sub ListBox1_Change()


Dim Sh As Worksheet
Dim Rng As Range
Dim NextCell As Range
Dim i As Long
Dim r As Long
Set Sh = Worksheets("ETC")
With Sh
If Not IsEmpty(.Cells(1, 1)) Then
Set Rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
Set NextCell = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
End If
End With
With ListBox1
' Add new selections
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) Then
If Not Rng Is Nothing Then
On Error Resume Next
r = WorksheetFunction.Match(.List(i), Rng, False)
If Err <> 0 Then
Err.Clear
NextCell = .List(i)
End If
On Error GoTo 0
Else
Sh.Cells(1, 1) = .List(i)
End If
With Sh
Set Rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
Set NextCell = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
End If
Next i

End With
End Sub

 

[Jerry Sullivan]

Hi gheyman,

Your original thread didn't identify that you might be using multi-column listboxes.
The code doesn't have provisions to return anything but the first column, and that was probably just to keep things simple since multi-column ListBoxes are use much less frequently than single column ListBoxes.

Here's a modified version that will use the BoundColumn property.

Private Sub ListBox1_Change()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim NextCell As Range
    Dim i As Long
    Dim r As Long
    Dim BoundCol As Long
    Set Sh = Worksheets("ETC")
    With Sh
        If Not IsEmpty(.Cells(1, 1)) Then
            Set Rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
            Set NextCell = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
    End With
    With ListBox1
        BoundCol = .BoundColumn
'       Add new selections
        For i = 0 To .ListCount - 1
            If .Selected(i) Then
                If Not Rng Is Nothing Then
                    On Error Resume Next
                    r = WorksheetFunction.Match(.List(i, BoundCol), Rng, False)
                        If Err <> 0 Then
                            Err.Clear
                            NextCell = .List(i, BoundCol)
                        End If
                    On Error GoTo 0
                Else
                    Sh.Cells(1, 1) = .List(i, BoundCol)
                End If
                With Sh
                    Set Rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
                    Set NextCell = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
                End With
            End If
        Next i
'       Remove items deselected
        For i = 0 To .ListCount - 1
            If Not .Selected(i) Then
                On Error Resume Next
                r = WorksheetFunction.Match(.List(i, BoundCol), Rng, False)
                If Err = 0 Then
                    Sh.Cells(r, 1).Delete shift:=xlUp
                Else
                    Err.Clear
                End If
                On Error GoTo 0
                With Sh
                    Set Rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
                    Set NextCell = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
                End With
            End If
        Next i
    End With
End Sub