VBA for a Multi Select Listbox results with NewLine

[crazyfrog]

Hi,

Is it possible to have some VBA in Sheet1:

1. That when a user click on a cell in a particular column within a specific sheet:

1.1 That they are presented with a multi select listbox (Showing 20 items stored in a column in Sheet2 )

1.2 And when the items are selected that the items are automatically written in the same cell that was clicked in Sheet1 with a new line break in between each item?

If so can someone post the code.....really appreciate it.

 

[Jaafar Tribak]

Workbook demo.

here is a way to dynamically add a MultiSelect Listbox when cell B1 of the active sheet is selected. Everytime an item is selected the cell B1 is updated with the newly selected item.

Place this in the worksheet module :

Option Explicit
 
Private WithEvents Lbx As MSForms.ListBox
Private oTarget As Range
Private sListBoxName As String
Private Const Cell_A1 As String = "b1" [COLOR=seagreen]'change addr as required.[/COLOR]
 
Private Sub Lbx_Change()
 
    Dim i As Long
    
    oTarget.ClearContents
    For i = 0 To Lbx.ListCount - 1
        If Lbx.Selected(i) Then
            If Len(oTarget) = 0 Then
                oTarget = Lbx.List(i)
            Else
                oTarget = _
                Trim(oTarget & vbNewLine & Lbx.List(i))
            End If
        End If
    Next
 
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
    Dim oListBox As OLEObject
    
    On Error Resume Next
    Me.OLEObjects(1).Delete
    
    If UCase(Target.Address(0, 0)) = UCase(Cell_A1) Then
        Application.DisplayFormulaBar = False
        Set oListBox = _
        Me.OLEObjects.Add(ClassType:="Forms.ListBox.1")
        With oListBox
             Names.Add "ListBoxName", .Name
            .Left = Target.Offset(1, 1).Left
            .Top = Target.Offset(2, 2).Top
            .Width = Me.StandardWidth * 10
            .Height = Me.StandardHeight * 10
            .ListFillRange = Sheets(2).Name & "!a1:a20"
            .Placement = xlFreeFloating
            .Object.MultiSelect = fmMultiSelectMulti
            With Application
                .OnTime Now + _
                TimeSerial(0, 0, 0.01), Me.CodeName & ".Hooklistbox"
                .CommandBars.FindControl(ID:=1605).Execute
            End With
        End With
    Else
        Application.DisplayFormulaBar = True
        Names("ListBoxName").Delete
        Range(Cell_A1).Interior.ColorIndex = 0
    End If
 
End Sub
 
Private Sub Hooklistbox()
 
    Application.CommandBars.FindControl(ID:=1605).Reset
    Set oTarget = ActiveCell
    ActiveCell.Interior.Color = vbYellow
   [COLOR=seagreen] 'display the listbox and hook it.
[/COLOR]    With Me.OLEObjects(Evaluate("ListBoxName"))
        .Visible = True
        Set Lbx = .Object
    End With
    
End Sub

Hope this answers your question.

Regards.

 

[MickG]

Hi, Try this:-
Place "Control ToolBox" ListBox in sheet, Set visible property to False.
Right Click Sheet Tab , Select "View Code", Paste code in VB Window.
Run Code below by Clicking in column "A", List Box Shows and List Box is filled from Column "A" Sheet2 and set to multi select.
Select Items in List Box, Select any cell in column "A".
Data is interserted in selected cell , List Box is Hidden.

Private [COLOR=navy]Sub[/COLOR] Worksheet_SelectionChange(ByVal Target [COLOR=navy]As[/COLOR] Range)
[COLOR=navy]Dim[/COLOR] Lst, Tran [COLOR=navy]As[/COLOR] [COLOR=navy]Integer,[/COLOR] Txt [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]If[/COLOR] Intersect(Target, Columns("A")) [COLOR=navy]Is[/COLOR] Nothing Or Target.Count > 1 [COLOR=navy]Then[/COLOR] [COLOR=navy]Exit[/COLOR] [COLOR=navy]Sub[/COLOR]
       Columns("A").ClearContents
    [COLOR=navy]If[/COLOR] ListBox1.Visible = False [COLOR=navy]Then[/COLOR]
        ListBox1.Visible = True
        Lst = Sheets("Sheet2").Range("A1:A20")
    [COLOR=navy]With[/COLOR] ListBox1
        .List = Lst
        .MultiSelect = fmMultiSelectMulti
    [COLOR=navy]End[/COLOR] With
[COLOR=navy]ElseIf[/COLOR] ListBox1.Visible = True [COLOR=navy]Then[/COLOR]
    [COLOR=navy]For[/COLOR] Tran = 0 To ListBox1.ListCount - 1
        [COLOR=navy]If[/COLOR] ListBox1.Selected(Tran) [COLOR=navy]Then[/COLOR]
            Txt = Txt & ListBox1.List(Tran) & Chr(10)
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Tran
        Target.Value = Txt
        ListBox1.Visible = False
[COLOR=navy]End[/COLOR] [COLOR=navy]If[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[crazyfrog]

Hi Mick,

Thanks for the code I tried it works, after a little play around I think I can be more specific.

1. I need a userform (userform1) with:

• Two multiselect listboxes (listA on left and listB on right)
• A button between the two listboxes (but_add) - adds to listA
• A button between the two listboxes (but_remove) - removes from listA
• A button on the form (but_submit) - to update cell

2. When I click in a cell in columnA of sheet 1, I get presented with the userform and listbox listA gets populated with the contents of the cell that has been clicked. (Will contain items separated with newline as before)

3. Listbox listB looks up everything in columnA of sheet2

4. When I select one or more items in listbox listB I want to click the button in between the listboxes (but_add) and those items I selected are added to listbox listA (But still remain in listB)

5. When I click the (but_submit) button everything in listA is added to the cell separated with newlines

6. I also need to remove one or more items from listA so I click the cell, userform appears, populates both listA and listB. I select one or more items from listA and click (but_remove) button which removes them from the list.

7. I follow up by clicking (but_submit) button which updates the contents of the cell I clicked with the contents of listA.

Can you or anyone else help with the code

 

[crazyfrog]

Here are some examples:

Select from listB then click Add to add to listA:

Select a cell then the useform is presented and cell contects is populted in listA:

http://ibexcentral.byethost32.com/formlistbox.xls

Thanks

 

[MickG]

Hi, This is slightly different as it only has an "Add" & "Remove" plus ListBox "ListA" & "ListB".
Button.
When You add somehing to "ListA" From "ListB", range "A1" Is also Updated , The same with the remove Button..
See How you Get on.
When You get The Userform Event Code Page up Paste all the code In the VB Window.
Button & List Box Names as your Post !!

Private [COLOR=navy]Sub[/COLOR] UserForm_Initialize()
[COLOR=navy]Dim[/COLOR] Lst1, Lst2
[COLOR=navy]On[/COLOR] [COLOR=navy]Error[/COLOR] [COLOR=navy]Resume[/COLOR] [COLOR=navy]Next[/COLOR]
Lst1 = Sheets("Sheet2").Range("A1:A20")
  Lst2 = Split(Range("A1"), Chr(10))
    [COLOR=navy]With[/COLOR] ListA
        .List = Application.Transpose(Lst2)
        .MultiSelect = fmMultiSelectMulti
    [COLOR=navy]End[/COLOR] With
 [COLOR=navy]With[/COLOR] ListB
        .List = Lst1
        .MultiSelect = fmMultiSelectMulti
    [COLOR=navy]End[/COLOR] With
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
'[COLOR=green][B]'''''''''''''''''''''''''''''[/B][/COLOR]
Private [COLOR=navy]Sub[/COLOR] But_Add_Click()
[COLOR=navy]Dim[/COLOR] Tran [COLOR=navy]As[/COLOR] [COLOR=navy]Integer,[/COLOR] Ray(), c [COLOR=navy]As[/COLOR] [COLOR=navy]Integer[/COLOR]
c = 0
[COLOR=navy]On[/COLOR] [COLOR=navy]Error[/COLOR] [COLOR=navy]Resume[/COLOR] [COLOR=navy]Next[/COLOR]
[COLOR=navy]For[/COLOR] Tran = 0 To ListA.ListCount - 1
      [COLOR=navy]If[/COLOR] ListA.List(Tran) <> "" [COLOR=navy]Then[/COLOR]
            ReDim Preserve Ray(c)
            Ray(c) = ListA.List(Tran)
            c = c + 1
      [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] Tran
[COLOR=navy]For[/COLOR] Tran = 0 To ListB.ListCount - 1
        [COLOR=navy]If[/COLOR] ListB.Selected(Tran) [COLOR=navy]Then[/COLOR]
            ReDim Preserve Ray(c)
            Ray(c) = ListB.List(Tran)
            c = c + 1
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Tran
 
[COLOR=navy]With[/COLOR] ListA
    .Clear
    .List = Application.Transpose(Ray)
[COLOR=navy]End[/COLOR] With
Range("A1") = Join(Application.Transpose(ListA.List), Chr(10))
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
'[COLOR=green][B]'''''''''''''''''''''''''''''[/B][/COLOR]
Private [COLOR=navy]Sub[/COLOR] But_Remove_Click()
[COLOR=navy]Dim[/COLOR] Tran [COLOR=navy]As[/COLOR] [COLOR=navy]Integer,[/COLOR] c [COLOR=navy]As[/COLOR] [COLOR=navy]Integer,[/COLOR] Ray()
c = 0
[COLOR=navy]For[/COLOR] Tran = 0 To ListA.ListCount - 1
        [COLOR=navy]If[/COLOR] Not ListA.Selected(Tran) [COLOR=navy]Then[/COLOR]
            ReDim Preserve Ray(c)
            Ray(c) = ListA.List(Tran)
            c = c + 1
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Tran
 
[COLOR=navy]With[/COLOR] ListA
   .Clear
   .List = Application.Transpose(Ray)
[COLOR=navy]End[/COLOR] With
Range("A1").Value = Join(Application.Transpose(ListA.List), Chr(10))
 
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[crazyfrog]

Hi Mick,

The majority of things work just some minor adjustments.

1. I trigger the userform initialise by double clicking any cell in any column in sheet1. Instead I want to trigger the userform by clicking in any cell in columnA (may be mouse up) in sheet1 from cell A2 and downwards.

3. When I click a cell for example a3, I want the cell information from a3 to appear in listA and any changes are reflected in this selected cell in this example a3. Click a3 change listA update a3.

In your example only a1 is updated (But I think you mentioned that)

4. I want listB to be populated with everything in sheet2 columnA but starting from A2 and downwards to the last entry in columnA.

5. I noticed that when I remove the last item in listA that I get an error message at ".List = Application.Transpose(Ray)"

The rest is working really nicely.

Cheers

 

[MickG]

Hi, Place this first bit of code in a Worksheet Event Module and the secon bit in the Userfor Event.
Nb:- Userform Shown in code as Userform4, change to suit

Private [COLOR=navy]Sub[/COLOR] Worksheet_SelectionChange(ByVal Target [COLOR=navy]As[/COLOR] Range)
[COLOR=navy]If[/COLOR] Not Intersect(Target, Columns("A")) [COLOR=navy]Is[/COLOR] Nothing And Target.Address <> "$A$1" And Target.Count = 1 [COLOR=navy]Then[/COLOR]
UserForm4.Show ' Change to suit
[COLOR=navy]End if[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Private [COLOR=navy]Sub[/COLOR] UserForm_Initialize()
[COLOR=navy]Dim[/COLOR] Lst1, Lst2, Rng [COLOR=navy]As[/COLOR] Range
[COLOR=navy]On[/COLOR] [COLOR=navy]Error[/COLOR] [COLOR=navy]Resume[/COLOR] [COLOR=navy]Next[/COLOR]
[COLOR=navy]With[/COLOR] Sheets("Sheet2")
Lst1 = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
[COLOR=navy]End[/COLOR] With
Lst2 = Split(Selection, Chr(10))
     [COLOR=navy]With[/COLOR] ListA
        .List = Application.Transpose(Lst2)
        .MultiSelect = fmMultiSelectMulti
    [COLOR=navy]End[/COLOR] With
 [COLOR=navy]With[/COLOR] ListB
        .List = Lst1
        .MultiSelect = fmMultiSelectMulti
    [COLOR=navy]End[/COLOR] With
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
'[COLOR=green][B]'''''''''''''''''''''''''''''[/B][/COLOR]
Private [COLOR=navy]Sub[/COLOR] But_Add_Click()
[COLOR=navy]Dim[/COLOR] Tran [COLOR=navy]As[/COLOR] [COLOR=navy]Integer,[/COLOR] Ray(), c [COLOR=navy]As[/COLOR] [COLOR=navy]Integer[/COLOR]
c = 0
[COLOR=navy]On[/COLOR] [COLOR=navy]Error[/COLOR] [COLOR=navy]Resume[/COLOR] [COLOR=navy]Next[/COLOR]
[COLOR=navy]For[/COLOR] Tran = 0 To ListA.ListCount - 1
      [COLOR=navy]If[/COLOR] ListA.List(Tran) <> "" [COLOR=navy]Then[/COLOR]
            ReDim Preserve Ray(c)
            Ray(c) = ListA.List(Tran)
            c = c + 1
      [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] Tran
[COLOR=navy]For[/COLOR] Tran = 0 To ListB.ListCount - 1
        [COLOR=navy]If[/COLOR] ListB.Selected(Tran) [COLOR=navy]Then[/COLOR]
            ReDim Preserve Ray(c)
            Ray(c) = ListB.List(Tran)
            c = c + 1
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Tran
 
[COLOR=navy]With[/COLOR] ListA
    .Clear
    .List = Application.Transpose(Ray)
[COLOR=navy]End[/COLOR] With
Selection = Join(Application.Transpose(ListA.List), Chr(10))
Unload Me
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
'[COLOR=green][B]'''''''''''''''''''''''''''''[/B][/COLOR]
Private [COLOR=navy]Sub[/COLOR] But_Remove_Click()
[COLOR=navy]Dim[/COLOR] Tran [COLOR=navy]As[/COLOR] [COLOR=navy]Integer,[/COLOR] c [COLOR=navy]As[/COLOR] [COLOR=navy]Integer,[/COLOR] Ray()
c = 0
[COLOR=navy]For[/COLOR] Tran = 0 To ListA.ListCount - 1
        [COLOR=navy]If[/COLOR] Not ListA.Selected(Tran) [COLOR=navy]Then[/COLOR]
            ReDim Preserve Ray(c)
            Ray(c) = ListA.List(Tran)
            c = c + 1
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Tran
 Selection.ClearContents
[COLOR=navy]With[/COLOR] ListA
    .Clear
 [COLOR=navy]If[/COLOR] c > 0 [COLOR=navy]Then[/COLOR]
   .List = Application.Transpose(Ray)
   Selection = Join(Application.Transpose(ListA.List), Chr(10))
 [COLOR=navy]End[/COLOR] If
[COLOR=navy]End[/COLOR] With
Unload Me
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[crazyfrog]

Hey Mick,

That works great !!!!!!

Only one thing, real sorry....I liked your previous example where the userform stayed put until I click the close button.

This allows me to add and remove to listA with the cell updated when I click "Add" or "remove", if the userform stayed put I could change my mine on the selections and close the userform when ready.

Can you help make the above happen?

Cheers

Paul

 

[crazyfrog]

Think I worked it out, remove the unload me from both buttons.

Is this right?

Very small thing to top it off:

1. When I select items from listB and click add, can you get it to clear the selections in listB as they currently stay highlighted?
2. When I click on an empty cell give listB focus (Cos I got to give listB focus first and then click the second time to get to select something)
3. When I click on a cell with items in give listA focus (I think this is done already)

Thanks for your help so far.

Paul