Question

以下代码是否存在明显问题？我想遍历所有列表框并填充选定的项目。

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

Answer 1

对于每个列表框的未知数量和未知数量的选定项目，我将构建一个包含结果的字符串，然后在每个行（列表框中的每个选定项目）的回车符Chr(10)上拆分字符串然后使用文本到列以获取正确单元格中的所有内容。它看起来像这样：

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

循环遍历excel vba中的列表框

1 个答案: