Copy selected rows to a new sheet based on list box

[TOM M]

Hi All,

I Have a userform with a listbox on it called Listbox2 which is populated by the user, this form works ok. In this list box there will be entries such as:

R001
R003
R004.

What i then want to do is scroll down row 14 of sheet 1 looking for any entries of R001 (there will be multiple rows) and copy them on to a new sheet. then loop and put all entries of R003 underneath and so on.

This is the code i have so far which doesn't work and is probably useless:

Dim i As Integer, x As Integer, y As Integer
Dim shAL As Worksheet
Dim shIS As Worksheet
Set shIS = Sheets("Individual Statements")
Set shAL = Sheets("Account Listings")
y = 1
i = 8
x = 1

Do While y < Me.ListBox2.ListCount

If Me.ListBox2.List = shAL.Cells(i, 14) Then

Do While shAL.Cells(i, 14) = Me.ListBox2.List


shAL.Rows(i).Select
Selection.Copy
shIS.Rows(x).Select
Selection.Paste
i = i + 1
x = x + 1
Loop

Else

y = y + 1


End If

Loop


End Sub


Any help would be greatly appreciated as i have been trying for 6 hours!!!!

Thanks in advance

Tom

 

[Saagar]

Question.

In your post, you said "i then want to do is scroll down row 14 of sheet 1 looking for any entries of R001"

In your code, you are looking at column-14, row-8 and checking for R001, R003 etc.
If cell(8,14) has desired value, then only you are looking at remaining cells, otherwise you care going to the next entry in the listbox.

Irrespective of cell(8,14) containing the desired value, do you want to continue looking at rows below for R001 before proceeding to R003?

 

[Saagar]

Check this thread - http://www.mrexcel.com/forum/showthread.php?t=578175

You may want something similar. If that is the case, you can modify the code to fit your needs. I can help you with it.

 

[Rick Rothstein]

See if this code does what you want...

Dim X As Long, LastRow As Long
Dim shAL As Worksheet, shIS As Worksheet, ToBeCopied As Range
Set shIS = Sheets("Individual Statements")
Set shAL = Sheets("Account Listings")
Application.ScreenUpdating = False
With shAL.Range("N8:N" & shAL.Cells(Rows.Count, "N").End(xlUp).Row)
  For X = 0 To ListBox2.ListCount - 1
    .Replace ListBox2.List(X), "=XXX" & ListBox2.List(X), xlPart
  Next
  On Error Resume Next
  Set ToBeCopied = .SpecialCells(xlFormulas).EntireRow
  .Replace "=XXX", "", xlPart
  ToBeCopied.Copy shIS.Range("A1")
End With
shIS.Cells.Sort Key1:=shIS.Range("N1"), Order1:=xlAscending
Application.ScreenUpdating = True