0

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

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
4

1 回答 1

2

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
于 2013-09-09T21:53:53.873 回答