Listbox selected values paste to worksheet

Question

 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

Then in listbox selected > 100 field excel responds very slow to copy them to worksheet

How to speed up this code?

Answer 1

You can reduce the number of cell writes using something like this:

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

If you have the same number of delimited items in each row of the listbox, you could create an array of arrays and then output that to the sheet in one write operation. Code would be something like this:

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)

Answer 2

or just Cells(i + 1, "B").Resize(counter, columnCount).Value = ListBoxArrSplitToRows