change code copy one column to multipe columns for selected items from list box to sheet

[Abdo]

hi
I got this code for @Norie

Private Sub CommandButton1_Click()
Dim I As Long
Dim cnt As Long
Dim arr()

    With ListBox1
        If .ListCount = 0 Then
            MsgBox "No data in listbox."
            Exit Sub
        End If

        For I = 0 To .ListCount - 1
            If .Selected(I) Then
                ReDim Preserve arr(cnt)
                arr(cnt) = .List(I)
                cnt = cnt + 1
            End If

        Next I
    End With

    If cnt = 0 Then
        MsgBox "No data selected."
    Else
        Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(arr) + 1).Value = Application.Transpose(arr)
    End If

End Sub

it just copies one column from list box into sheet when select specific rows from listbox , but I want copying all of the columns from list box to sheet when select rows from listbox .
the columns in listbox are 8 and the sheet are from A:H
cany anybody help me , please?

 

[Takae]

Hope this helps.

Private Sub CommandButton1_Click()
Dim i As Long, j As Long
Dim cnt As Long
Dim arr()

    With ListBox1
        If .ListCount = 0 Then
            MsgBox "No data in listbox."
            Exit Sub
        End If

        For i = 0 To .ListCount - 1
            If .Selected(i) Then
                ReDim Preserve arr(7, cnt)
                For j = 0 To 7
                    arr(j, cnt) = .List(i, j)
                Next
                cnt = cnt + 1
            End If
        Next i
    End With

    If cnt = 0 Then
        MsgBox "No data selected."
    Else
        Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(cnt, 8).Value = Application.Transpose(arr)
    End If
End Sub

 

[Abdo]

well done ! is there any way to clear the range in sheet from row2 before copy from listbox?
I mean delete the old data in sheet before copy from listbox .

 

[Takae]

Is this?
By the way, this code hasn't specified the sheet to paste, is that okay?

Private Sub CommandButton1_Click()
Dim i As Long, j As Long, cnt As Long
Dim arr()

    With ListBox1
        If .ListCount = 0 Then
            MsgBox "No data in listbox."
            Exit Sub
        End If

        For i = 0 To .ListCount - 1
            If .Selected(i) Then
                ReDim Preserve arr(7, cnt)
                For j = 0 To 7
                    arr(j, cnt) = .List(i, j)
                Next
                cnt = cnt + 1
            End If
        Next i
    End With

    If cnt = 0 Then
        MsgBox "No data selected."
    Else
        Range(Range("A2"), Range("A2").SpecialCells(xlLastCell)).ClearContents
        Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(cnt, 8).Value = Application.Transpose(arr)
    End If
End Sub

 

[Abdo]

By the way, this code hasn't specified the sheet to paste,

depends on active sheet .

is that okay?

yes . many thanks buddy