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.

 

[crazyfrog]

Missed adding to my last post..

4. Is there a way to select more than one at a time or all in listA with shift ?
5. Is there a way to select more than one at a time or all in listB with shift ?

Ta

 

[crazyfrog]

Missed adding to my last post..

4. Is there a way to select more than one at a time or all in listA with shift ?
5. Is there a way to select more than one at a time or all in listB with shift ?
6. I wonder if we can make the selection userform generic so that I could have a control sheet to tell it where to look to populate listB and where listA writes to:

If I had a sheet called "control" and in there in columnA would be the "target sheet", columnB would contain the "target column" and in columnC would be the "source sheet" and "source column".

So the control sheet would look like this:

Control

<table style="padding-right: 2pt; padding-left: 2pt; font-size: 10pt; font-family: Arial,Arial; background-color: rgb(255, 255, 255);" border="1" cellpadding="0" cellspacing="0"> <colgroup> <col style="font-weight: bold; width: 30px;"> <col style="width: 116px;"> <col style="width: 92px;"> <col style="width: 122px;"> <col style="width: 148px;"></colgroup> <tbody> <tr style="font-weight: bold; font-size: 8pt; background-color: rgb(202, 202, 202); text-align: center;"> <td>
</td> <td>A</td> <td>B</td> <td>C</td> <td>D</td></tr> <tr style="height: 17px;"> <td style="font-size: 8pt; background-color: rgb(202, 202, 202); text-align: center;">1</td> <td style="background-color: rgb(204, 255, 255);">Target SheetName</td> <td style="background-color: rgb(204, 255, 255);">Target Column</td> <td style="background-color: rgb(204, 255, 255);">Source Sheet</td> <td style="background-color: rgb(204, 255, 255); text-align: left;">Source Column</td></tr> <tr style="height: 17px;"> <td style="font-size: 8pt; background-color: rgb(202, 202, 202); text-align: center;">2</td> <td>Sheet1</td> <td>A</td> <td>Sheet5</td> <td style="text-align: left;">A</td></tr> <tr style="height: 17px;"> <td style="font-size: 8pt; background-color: rgb(202, 202, 202); text-align: center;">3</td> <td>Sheet1</td> <td>D</td> <td>Sheet5</td> <td style="text-align: left;">B</td></tr> <tr style="height: 17px;"> <td style="font-size: 8pt; background-color: rgb(202, 202, 202); text-align: center;">4</td> <td>Sheet2</td> <td>C</td> <td>Sheet5</td> <td style="text-align: left;">A</td></tr> <tr style="height: 17px;"> <td style="font-size: 8pt; background-color: rgb(202, 202, 202); text-align: center;">5</td> <td>Sheet3</td> <td>N</td> <td>Sheet5</td> <td style="text-align: left;">C</td></tr> <tr style="height: 17px;"> <td style="font-size: 8pt; background-color: rgb(202, 202, 202); text-align: center;">6</td> <td>Sheet4</td> <td>A</td> <td>Sheet5</td> <td style="text-align: left;">D</td></tr></tbody></table>
If we could do the changes in the last posts this thing would be amazing.

Cheers again.

 

[MickG]

Hi, Alter Code below where shown:-
Nb:-In Any ComBoBox Properties List Find "Multiselet" and then Ckick "F1" for Information.

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("A1"), .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)
       [COLOR=darkgreen]'Altered below[/COLOR]
 .MultiSelect = fmMultiSelectExtended '[COLOR=green][B]fmMultiSelectMulti[/B][/COLOR]
 
    [COLOR=navy]End[/COLOR] With
 [COLOR=navy]With[/COLOR] ListB
        .List = Lst1
      [COLOR=darkgreen]'Altered below[/COLOR]
 .MultiSelect = fmMultiSelectExtended '[COLOR=green][B]fmMultiSelectMulti[/B][/COLOR]
    [COLOR=navy]End[/COLOR] With
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[MickG]

Right, With Your "Select" Form In sheet "Control". Place this First bit code in the Worksheet_change Event and the second Bit od code in your Userform Event module.
To Run :- Select "A1" Userform Appears.
Click Userform, Two Input Boxes appear Select Range in Col "A" for Sheet Name and Col "C" for Source Sheet Name.
List Boxes filled
Run as before "Add" & "Remove" as before.
NB:- There is a New Button "But_Sum" to Submit the info from "ListA" Back to the sheet it Came from.
NB:- Variable Declaration at top of Code.

Private [COLOR=navy]Sub[/COLOR] Worksheet_SelectionChange(ByVal Target [COLOR=navy]As[/COLOR] Range)
[COLOR=navy]Dim[/COLOR] Trng [COLOR=navy]As[/COLOR] Range, Srng [COLOR=navy]As[/COLOR] Range
[COLOR=navy]If[/COLOR] Target.Address = "$A$1" And Target.Count = 1 [COLOR=navy]Then[/COLOR]
    [COLOR=navy]With[/COLOR] UserForm1
        .Show vbModeless
        .Caption = "Click This Form to [COLOR=navy]Select[/COLOR] ""Target/Source"" "
        .Left = 300
    [COLOR=navy]End[/COLOR] With
[COLOR=navy]End[/COLOR] [COLOR=navy]If[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Option Explicit
[COLOR=navy]Dim[/COLOR] Lst1 [COLOR=navy]As[/COLOR] Range, Lst2 [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Trng [COLOR=navy]As[/COLOR] Range, Srng [COLOR=navy]As[/COLOR] Range
'[COLOR=green][B]'''''''''''''''''''''''''''''''''''''''''''''[/B][/COLOR]
'[COLOR=green][B]''''''''''''''''''''''''''''''''''''''''[/B][/COLOR]
Private [COLOR=navy]Sub[/COLOR] But_Sub_Click()
[COLOR=navy]If[/COLOR] Not Trng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
[COLOR=navy]With[/COLOR] Sheets(Trng.Value)
.Columns(Trng.Next.Value).Clear
.Range(Trng.Next & "1").Resize(ListA.ListCount).Value = ListA.List
[COLOR=navy]End[/COLOR] With
[COLOR=navy]End[/COLOR] If
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
'[COLOR=green][B]'''''''''''''''''''''''''''''''''''''''''''[/B][/COLOR]
Private [COLOR=navy]Sub[/COLOR] UserForm_Click()
[COLOR=navy]On[/COLOR] [COLOR=navy]Error[/COLOR] [COLOR=navy]Resume[/COLOR] [COLOR=navy]Next[/COLOR]
    [COLOR=navy]Set[/COLOR] Trng = Application.InputBox(Left:=300, prompt:="Please [COLOR=navy]Select[/COLOR] Target Sheet ", Title:="Target Sht/Col", Type:=8)
    [COLOR=navy]Set[/COLOR] Srng = Application.InputBox(Left:=300, prompt:="Please [COLOR=navy]Select[/COLOR] Source Sheet ", Title:="Source Sht/Col", Type:=8)
[COLOR=navy]With[/COLOR] Sheets(Trng.Value)
    [COLOR=navy]Set[/COLOR] Lst1 = .Range(.Range(Trng.Next & "1"), .Range(Trng.Next & Rows.Count).End(xlUp))
[COLOR=navy]End[/COLOR] With
[COLOR=navy]With[/COLOR] Sheets(Srng.Value)
   [COLOR=navy]Set[/COLOR] Lst2 = .Range(.Range(Srng.Next & "1"), .Range(Srng.Next & Rows.Count).End(xlUp))
 [COLOR=navy]End[/COLOR] With
     [COLOR=navy]With[/COLOR] UserForm1.ListA
        .List = Lst1.Value
        .MultiSelect = fmMultiSelectExtended
    [COLOR=navy]End[/COLOR] With
 [COLOR=navy]With[/COLOR] UserForm1.ListB
        .List = Lst2.Value
        .MultiSelect = fmMultiSelectExtended
    [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
[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
 [COLOR=navy]If[/COLOR] c > 0 [COLOR=navy]Then[/COLOR]
   .List = Application.Transpose(Ray)
 [COLOR=navy]End[/COLOR] If
[COLOR=navy]End[/COLOR] With
 
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[crazyfrog]

Hi Mick,

Thanks for replying to my requests.....

I am a bit lost at present with what I got to put where.

Can you post the entire code and which places to paste code.

Either that or attach a workbook?

Really sorry to have to ask.

Cheers

Paul

 

[MickG]

Hi, Try the attached :-
ListBox Multisheet.xls
Regards Mick

 

[crazyfrog]

Hi Mick,

Sorry haven't got back to you....will make some time to review and get back to you tonight (Aussie time)