列表框选定值粘贴到工作表答案

【问题标题】：Listbox selected values paste to worksheet列表框选定值粘贴到工作表
【发布时间】：2014-05-08 09:26:28
【问题描述】：

 i=19

With ListBox1
    'clearing previous values from sheet
    range(Cells(i + 2, 1).Address & ":" & Cells(endRwow, 7).Address).ClearContents

    ListBoxArrSelected = vbNullString

    For y = 0 To .ListCount - 1
        If .Selected(y) Then
            ' concatenate all selected strings
            ListBoxArrSelected = ListBoxArrSelected & "~" & ListBox1.List(y)
        End If
    Next y

    ' fill array with concatenated all selected strings spliting to rows
    ListBoxArrSplitToRows = Split(ListBoxArrSelected, "~")

    For UR = 1 To UBound(ListBoxArrSplitToRows, 1) + 1
        ' fill array with concatenated all selected strings spliting to colomuns
        ListBoxArrSplitToCell = Split(ListBoxArrSplitToRows(UR - 1), "·")

        For URc = 1 To UBound(ListBoxArrSplitToCell, 1) + 1
            'paste to sheet
            Cells(i + UR, 1).value = timeStr
            Cells(i + UR, URc + 1).value = ListBoxArrSplitToCell(URc - 1)
        Next URc
    Next UR
End With

然后在列表框中选择> 100 个字段 excel 响应非常慢以将它们复制到工作表

如何加速这段代码？

【问题讨论】：

请举例说明
这里不要连接 'For y = 0 To .ListCount - 1 If .Selected(y) Then ' 连接所有选中的字符串 ListBoxArrSelected = ListBoxArrSelected & "~" & ListBox1.List(y) End If接下来 y' 将值放入字典或数组中。因此，下次您不必使用“~”拆分所有值并为每个值进行迭代。这将节省您的时间。

标签： arrays vba excel split

【解决方案1】：

您可以使用以下方式减少单元格写入次数：

i = 19

  With ListBox1
    Range(Cells(i + 2, 1), Cells(endRwow, 7)).ClearContents

    ListBoxArrSelected = vbNullString

        For y = 0 To .ListCount - 1
            If .Selected(y) Then
                ListBoxArrSelected = ListBoxArrSelected & "~" & ListBox1.List(y)
            End If
        Next y
            ListBoxArrSplitToRows = Split(ListBoxArrSelected, "~")

            Cells(i + 1, 1).Resize(UBound(ListBoxArrSplitToRows, 1) + 1).Value = timeStr
            For UR = 1 To UBound(ListBoxArrSplitToRows, 1) + 1
                ListBoxArrSplitToCell = Split(ListBoxArrSplitToRows(UR - 1), "·")
                Cells(i + UR, 2).Resize(, UBound(ListBoxArrSplitToCell, 1) + 1).Value = ListBoxArrSplitToCell
            Next UR

    End With

如果列表框的每一行中有相同数量的分隔项，则可以创建一个数组数组，然后在一次写入操作中将其输出到工作表。代码是这样的：

Dim ListBoxArrSplitToRows()
Dim counter                     As Long
Dim columnCount                 As Long
i = 19

Range(Cells(i + 2, 1), Cells(endRwow, 7)).ClearContents

With ListBox1

    ReDim ListBoxArrSplitToRows(.ListCount - 1)

    For y = 1 To .ListCount
        If .Selected(y - 1) Then
            ' load subarray into array
            ListBoxArrSplitToRows(counter) = Split(.List(y - 1), "·")
            counter = counter + 1
        End If
    Next y
End With

' resize array to used extent
ReDim Preserve ListBoxArrSplitToRows(counter - 1)
' get column count using first subarray
columnCount = UBound(ListBoxArrSplitToRows(0)) + 1
Cells(i + 1, "B").Resize(counter, columnCount).Value = Application.Index(ListBoxArrSplitToRows, 0, 0)

【讨论】：

当我查看您的注释代码和@Rory 的代码时，我发现缺少逗号(,) 'Resize(, UBound' 和额外的逗号' (UBound(,ListBoxArrSplitToCell '。尝试使用它。
用一个使用数组数组的例子更新了代码。
它调整数组的大小，使其足够大，可以在需要时接受列表中的所有条目。它在循环后被调整回实际使用的数据。
没有。仅当项目被选中时计数器才会增加 - 它与 y 不同步。
也许你能帮我解决这个stackoverflow.com/questions/23540045/… ？

【解决方案2】：

或者只是 Cells(i + 1, "B").Resize(counter, columnCount).Value = ListBoxArrSplitToRows

【讨论】：