CODEWITHSUNDEEP
excelvba
user2759430
user2759430

Reputation: 61

Loop through listboxes in excel vba

Is there an apparent problem with the following codes? I want to loop through all listboxes and populate selected items. 

Dim lRw As Integer
Dim iX As Integer, iY As Integer
Dim i As Integer

For i = 1 To 10

With ActiveSheet
.Columns(i + 10).ClearContents
End With

    For iX = 0 To ListBox(i).ListCount - 1
        If ListBox(i).Selected(iX) = True Then
        With Sheet1
            lRw = .Cells(.Rows.Count, i + 11).End(xlUp).Row + 1
            For iY = 0 To ListBox(i).ColumnCount - 1
                .Cells(lRw, iY + i).Value = ListBox(i).List(iX, iY)
            Next iY
        End With

        End If
    Next iX
Next i

Upvotes: 1

Views: 17443

Answers (1)

tigeravatar
tigeravatar

Reputation: 26640

With an unkown number of listboxes and an unknown number of selected items each, I would build a string with the results, then split the string on carriage returns Chr(10) for each line (each selected item in a listbox) and then use a text to columns to get everything in the correct cells. It would look like this:

Sub tgr()

    Dim wsLists As Worksheet
    Dim wsDest As Worksheet
    Dim ctrl As OLEObject
    Dim strOutput As String
    Dim arrOutput() As String
    Dim i As Long, j As Long

    Set wsLists = Sheets("Sheet1")  'The sheet containing the listboxes
    Set wsDest = Sheets("Sheet2")   'The sheet where the output will go

    For Each ctrl In wsLists.OLEObjects
        If TypeName(ctrl.Object) = "ListBox" Then
            For i = 0 To ctrl.Object.ListCount - 1
                If ctrl.Object.Selected(i) Then
                    If Len(strOutput) > 0 Then strOutput = strOutput & Chr(10)
                    For j = 0 To ctrl.Object.ColumnCount - 1
                        strOutput = strOutput & ctrl.Object.List(i, j) & vbTab
                    Next j
                End If
            Next i
        End If
    Next ctrl

    If Len(strOutput) > 0 Then
        wsDest.Range("K:T").ClearContents
        arrOutput = Split(strOutput, Chr(10))
        With wsDest.Cells(Rows.Count, "K").End(xlUp).Offset(1).Resize(UBound(arrOutput) - LBound(arrOutput) + 1)
            .Value = Application.Transpose(arrOutput)
            .TextToColumns Tab:=True
        End With
        Erase arrOutput
    End If

End Sub

Upvotes: 3

Related Questions