listbox multiple selections

[Paul]

Hi,

I've got some code that I use for transferring listbox values from the
listbox to a worksheet and at the same time to another listbox as well. The
chosen values are also being transferred in a different worksheet, this
worksheet is used as a source for the listboxes, the original values are in
Column A, copies of these values are in Column C and after a value is chosen
it will be deleted from column C and added to column E. This because when I
reopen the document I can load the chosen values from these columns for
displaying in the listboxes. This complete process is reversible, check code.

The codes I'm using are;

For the listbox to chose from;

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

With Worksheets(2).Range("A1:A32763")
Set c = .FIND(ListBox1.Value, After:=[A32763], LookIn:=xlValues)

If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Cells.Offset(0, 4) = c.Value
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With

With Worksheets(2).Range("C1:C32763")
Set d = .FIND(ListBox1.Value, After:=[C32763], LookIn:=xlValues)

If Not d Is Nothing Then
firstAddress = d.Address
Do
d.Cells.Clear
Loop While Not d Is Nothing And d.Address <> firstAddress
d.Cells.Delete
End If
End With

ActiveCell = ListBox1.Value

For Each Item In ActiveCell
TDL.ListBox7.AddItem Item
Next Item

With ListBox1
If .ListIndex >= 0 Then
.RemoveItem .ListIndex
.ListIndex = -1
End If
End With

Label1.Caption = "X: " & (ListBox1.ListCount)
Label7.Caption = "Allocated " & (ListBox7.ListCount)

ActiveCell.Offset(0, 1).Activate

End Sub

And this one for the listbox for the already chosen values;

Private Sub ListBox7_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

With Worksheets(2).Range("A1:A32763")
Set c = .FIND(ListBox7.Value, After:=[A32763], LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Cells.Offset(0, 2).Insert
c.Cells.Offset(0, 2) = c.Value
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With

With Worksheets(2).Range("E1:E32763")
Set e = .FIND(ListBox7.Value, After:=[E32763], LookIn:=xlValues)
If Not e Is Nothing Then
firstAddress = e.Address
Do
e.Cells.Clear
Loop While Not e Is Nothing And e.Address <> firstAddress
e.Cells.Delete
End If
End With

With Worksheets(2).Range("F1:F32763")
Set g = .FIND(ListBox7.Value, After:=[F32763], LookIn:=xlValues)
If Not g Is Nothing Then
firstAddress = g.Address
Do
g.Cells.Clear
Loop While Not g Is Nothing And g.Address <> firstAddress
g.Cells.Delete
End If
End With

With Worksheets(1).Range("E5:E200")
Set f = .FIND(ListBox7.Value, After:=[E200], LookIn:=xlValues)
If Not f Is Nothing Then
firstAddress = f.Address
Do
f.Cells.Value = ""
Loop While Not f Is Nothing And f.Address <> firstAddress
End If
End With

ActiveCell.Offset(0, 15) = ListBox7.Value

For Each Item In ActiveCell.Offset(0, 15)
TDL.ListBox1.AddItem Item, (c.Row - 1)
Next Item

ActiveCell.Offset(0, 15).Delete

With ListBox7
If .ListIndex >= 0 Then
.RemoveItem .ListIndex
.ListIndex = -1
End If
End With

Label7.Caption = "Allocated: " & (ListBox7.ListCount)
Label1.Caption = "X: " & (ListBox1.ListCount)

End Sub


Above codes are working great but now I would like to do the same thing with
a multiselection listbox. I can set up the listbox to be a multiselection
one, that's the easy part. I would like to do exactly the same with the
multivalues as with the single values.

I would like that the first value of the selection goes into the activecell
and the last values of the selection goes into the activecell + 1 column (so
propably via an offset(0,1)). this via a commandbutton.

I would like that all the selected items to be moved from listbox4 to
listbox9.
I would like that all the selected items to be removed from worksheets(5)
column C and entered in column E.
I would like to be able to reverse these actions by doing the actions the
other way around.

Hope anybody can help me with this.

Cheers,

Paul

 

[Incidental]

Hi Paul

I have had a look at your code but it got a little confusing to I
worked from your description in the hope that you will be able to work
the code into your project making the alterations to fit. To test set
up a Userform with two multiselect listboxes called ListBox4 and
ListBox9 and a button below each of the listboxes to launch the code,
they should be named ListBox4Button and ListBox9Button. Then Paste
the following code into the userform module.

It works by first passing the items selected in the list into the next
available cell in either column C or E depending on which List you are
working from. It will also pass the values and list indexes of the
selected items into an array (one for each, I could have put both into
a single array but I find this gets confusing to keep track of) It
will then look for the value in the corresponding column and remove it
and load the value into the opposite ListBox. Lastly it will remove
the selected values from the original ListBox. If you have trouble
let me know and I will comment the code and try to help.

P.S. you will need values in the columns C, D to check against or you
will get an error. I suppose this could be trapped using onerror.
Also in the lines ReDim ValueArr(0 To 100) & ReDim IndexArr(0 To 100)
ensure that you replace 100 with a number greater than you expect the
array to get, i.e. a possible 154 maximum items in a list use 160 or
so.

Option Explicit
Dim i, NewRow, Elm As Integer
Dim Ctrl1, Ctrl2 As Control
Dim Counter As Integer
Dim ValueArr As Variant
Dim IndexArr As Variant
Dim FoundCell As Range

Private Sub ListBox4Button_Click()

NewRow = [E65535].End(xlUp).Row + 1

Set Ctrl1 = ListBox4

Set Ctrl2 = ListBox9

Call MovingStuff

End Sub
Private Sub ListBox9Button_Click()

NewRow = [C65535].End(xlUp).Row + 1

Set Ctrl1 = ListBox9

Set Ctrl2 = ListBox4

Call MovingStuff

End Sub

Sub MovingStuff()

Elm = 0

ReDim ValueArr(0 To 100)
ReDim IndexArr(0 To 100)

For i = 0 To Ctrl1.ListCount - 1

If Ctrl1.Selected(i) = True Then

If Ctrl1.Name = "ListBox4" Then

Cells(NewRow, 5).Value = Ctrl1.List(i)

Else

Cells(NewRow, 3).Value = Ctrl1.List(i)

End If

NewRow = NewRow + 1

ValueArr(Elm) = Ctrl1.List(i)

IndexArr(Elm) = i

Elm = Elm + 1

End If

Next

ReDim Preserve ValueArr(0 To Elm)
ReDim Preserve IndexArr(0 To Elm)

For i = 0 To Elm

If Ctrl1.Name = "ListBox4" Then

Set FoundCell = Worksheets("Sheet5").[C:C].Find _
(What:=ValueArr(i), LookAt:=xlWhole)

Else

Set FoundCell = Worksheets("Sheet5").[E:E].Find _
(What:=ValueArr(i), LookAt:=xlWhole)

End If

FoundCell.Delete Shift:=xlUp

Ctrl2.AddItem (ValueArr(i))

Next

Counter = 0

For i = 0 To UBound(IndexArr) - 1

Ctrl1.RemoveItem (IndexArr(i) - Counter)

Counter = Counter + 1

Next

End Sub

Hope this helps

Steve