copy selected listbox items and paste to a specific sheet

hi All,

I managed to find a bit code for a userform im working on, i have 2 listboxes, Multiextended, i can transfer from listbox1 to listbox 2 ok, checkbox to select all, move items back n forward, but the code I have to copy listbox2 to a sheet called Cert_Input finding the first blank cell in E seems to take forever, any help?

Private Sub CommandButton1_Click()
Dim Litem As Long, LbRows As Long, LbCols As Long
Dim bu As Boolean
Dim Lbloop As Long, Lbcopy As Long

LbRows = ListBox2.ListCount - 1

For Litem = 0 To LbRows
If ListBox2.Selected(Litem) = True Then
bu = True
Exit For
End If
Next

If bu = True Then
With Sheets("Cert_Input").Cells(Rows.Count, 5).End(xlUp).Offset(1, 0)

For Litem = 0 To LbRows
If ListBox2.Selected(Litem) = True Then 'Row selected
'Increment variable for row transfer range
Lbcopy = Lbcopy + 1
For Lbloop = 0 To LbCols
'Transfer selected row to relevant row of transfer range
.Cells(Lbcopy, Lbloop + 1) = ListBox2.List(Litem, Lbloop)

Next Lbloop
End If
Next

End With

Else
MsgBox "Nothing chosen", vbCritical
End If
MsgBox "The Selected Data Are Copied.", vbInformation

End With
End Sub

Originally Posted by Tinbendr

See if this helps.

Please Login or Register  to view this content.

Thanks, ill give it a try first thing in the morning, let you know the outcome. Brains frazzled.

Hi
It comes up, a Run time error 1004, highlights this row, not gonna get a more indepth look at it till this afternoon,

.Cells(Lbcopy, Lbloop + 1) = ListBox2.List(Litem, Lbloop)

Thanks

Hi Tinbendr, Thanks, but kinda still takes its time, maybe My computer slow, but seems to run through each item, sometimes the list might have 5 items, then computer goes through the processing stage 5 times, but the list could have 100 items, goes through it for each part also.

Finally solved it, much faster, thanks for your help, code as follows:
Private Sub CommandButton1_Click()
Dim i As Long
Dim ary

ReDim ary(0 To 0)
With Me.ListBox2
For i = 0 To .ListCount - 1
If .Selected(i) Then
ReDim Preserve ary(1 To UBound(ary) + 1)
ary(UBound(ary)) = .List(i)
End If
Next
End With

Sheets("Cert_Input").Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Resize(UBound(ary)).Value _
= Application.Transpose(ary)
End Sub



Private Sub UserForm1_Initialize()
Dim i As Long

For i = 65 To 85
Me.ListBox2.AddItem Chr(i)
Next
End Sub