Active X listbox Multi-Select

[mothboy]

Hi,

I'm an absolute VBA novice and am stuck with some code that I've been give to output multi listbox selections into a single cell. I've searched for an age to find an explanation I can understand but failed miserably - please help me retain my sanity

Everything works well until the file is saved, on re-opening the check boxes in the list box have lost the selections (the output cell retains the original selections).

If someone could post back corrected code I would be your new bff, the code I'm using is as follows:


Private Sub ListBox1_Change()
'Output Cell
OutCell = "A1"


Dim outString As String, i As Long


outString = vbNullString
First = 0
With ListBox1
For i = 0 To .ListCount - 1
If .Selected(i) Then
If First = 0 Then
outString = .List(i)
First = 1
Else
outString = outString & ", " & .List(i)
End If
End If
Next i
End With
Range(OutCell).Value = outString


End Sub

 

[mothboy]

Re: Active X listbox multi - please Heeeeeeeeeeeelllllllllllllllllllllllllpppppppppppppp

wooooooooooooohoooooooooooooooooooo

that did the trick also applied it to the sheets I am setting up and it's working there too!!

When I started I didn't realise it would be so tricky to set-up

again - many many thanks for all the help - sanity restored!!

 

[Tiffstar82]

Re: Active X listbox multi - please Heeeeeeeeeeeelllllllllllllllllllllllllpppppppppppppp

I am attempting to use the above but have three listboxes on the same spreadsheet. When I save and close the boxes populate incorrectly upon opening. I have tried several different ways to change the Open Explicit to separate out the list but am failing. Can you tell me what I'm doing wrong?

Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Call SaveSelections
End Sub
Private Sub Workbook_Open()
    Call RestoreSelections
End Sub
Private Sub Workbook_Open1()
Dim i As Long
Dim arrSelected
Dim ans As Variant
Application.ScreenUpdating = True
       
        
If Sheet3.Range("G2").Value = "" And Sheet3.Range("H2").Value = "" And Sheet3.Range("I1").Value = "" Then Exit Sub
arrSelected = Split(Sheet3.Range("G2"), ",")
        
        
    For i = 0 To Sheet3.ListBox1.ListCount - 1
         ans = Application.Match(Sheet3.ListBox1.List(i), arrSelected, 0)
         If Not IsError(ans) Then
            Sheet3.ListBox1.Selected(i) = True
         End If
         
    Next i
    
arrSelected = Split(Sheet3.Range("H2"), ",")
    
    For i = 0 To Sheet3.ListBox3.ListCount - 1
         ans = Application.Match(Sheet3.ListBox3.List(i), arrSelected, 0)
         If Not IsError(ans) Then
            Sheet3.ListBox3.Selected(i) = True
         End If
    Next i
    
arrSelected = Split(Sheet3.Range("I2"), ",")
    
    For i = 0 To Sheet3.ListBox4.ListCount - 1
         ans = Application.Match(Sheet3.ListBox4.List(i), arrSelected, 0)
         If Not IsError(ans) Then
            Sheet3.ListBox4.Selected(i) = True
         End If
    Next i
    
    
    Application.ScreenUpdating = True
    Save
    
End Sub
Private Sub SaveSelections()
    
    Dim arr() As Variant, i As Long, j As Long
    
If Sheet3.Range("G2").Value <> "" Then
    With Sheet3.OLEObjects("ListBox1").Object
        If .ListIndex > 0 Then
            For i = 0 To .ListCount - 1
                If .Selected(i) Then
                    j = j + 1
                    ReDim Preserve arr(1 To j)
                    arr(j) = i
                End If
            Next
                     Names.Add Name:="Selections", RefersTo:=arr, Visible:=False
        End If
    End With
    
End If
    
    
If Sheet3.Range("H2").Value <> "" Then
    With Sheet3.OLEObjects("ListBox3").Object
        If .ListIndex > 0 Then
            For i = 0 To .ListCount - 1
                If .Selected(i) Then
                    j = j + 1
                    ReDim Preserve arr(1 To j)
                    arr(j) = i
                End If
            Next
                     Names.Add Name:="Selections", RefersTo:=arr, Visible:=False
        End If
    End With
End If
    
    
If Sheet3.Range("I2").Value <> "" Then
     With Sheet3.OLEObjects("ListBox4").Object
        If .ListIndex > 0 Then
            For i = 0 To .ListCount - 1
                If .Selected(i) Then
                    j = j + 1
                    ReDim Preserve arr(1 To j)
                    arr(j) = i
                End If
            Next
                     Names.Add Name:="Selections", RefersTo:=arr, Visible:=False
        End If
    End With
End If
    
End Sub
Private Sub RestoreSelections()
    
    Dim arr As Variant, i As Integer
    arr = [Selections]
        
    With Sheet3.OLEObjects("ListBox1").Object
        For i = 1 To UBound(arr)
            .Selected(arr(i)) = True
        Next
    End With
    
    With Sheet3.OLEObjects("ListBox3").Object
        For i = 1 To UBound(arr)
            .Selected(arr(i)) = True
        Next
    End With
    
    With Sheet3.OLEObjects("ListBox4").Object
        For i = 1 To UBound(arr)
            .Selected(arr(i)) = True
        Next
    End With
    
End Sub