Not looping copy & paste, find each X, paste to new sheet?
Posted by Joe Was on August 15, 2001 11:12 AM
This code only works for the first test. It tests for a "X" in column "A" if it finds a "X" it copies the whole row and pastes it to a different sheet. It should loop back and find the next "X" but it does not?
A fix or other solution would be much appreciated!
Sub Priority()
'Find all the rows that have a "X" in column "A" copy
'that row to the next blank row on a different sheet.
X = 1
Do
X = X + 1
'Look for row in column "A" that meets test.
Worksheets("Want_Full").Select
If Cells(X, 1) = "X" Then
'Select row that meets test.
Range(Cells(X, 1), Cells(X, 7)).Select
'Copy row that meets test.
Selection.Copy
'Paste to next blank row on different sheet.
Worksheets("Want_Now").Select
Range("A65536").End(xlUp).Select
Worksheets("Want_Now").Paste
Else
End If
'Find all the rows that have "X" in column "A"
'and do the copy & paste from above.
Loop Until Cells(X + 1, 1) = "X"
End Sub
Posted by neo on August 15, 2001 11:31 AM
have you tried...
have you tried incorporating the autofilter in rather than doing a loop to search for information? If done carefully this will work much faster than any loop statement without increasing your file size by more than is necessary :
Application.ScreenUpdating = False
Selection.AutoFilter
Selection.AutoFilter Field:=11, Criteria1:="x"
Selection.End(xlDown).Select
Selection.End(xlToRight).Select
Range(Selection, Cells(1)).Select
Selection.Copy
Sheets("Sheet5").Activate
Range("A1").Activate
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
ActiveSheet.Previous.Select
Range("A1").Select
Selection.AutoFilter
Application.ScreenUpdating = True
neo
Posted by Joe Was on August 17, 2001 7:15 AM
neo, Thanks for your help.
The autofilter had problems in my application I used all three, yes they could be faster but you can get better control in some applications with a loop. I went with the code below with some modifications and added additional modules.JSW
Sub Priority()
'Find all the rows ("A:G") that have a "X" in column "A" copy
'that row to the next blank row on a different sheet.
Worksheets("Want_Full").Select
For Each r In Worksheets("Want_Full").UsedRange.Rows
n = r.Row
If Worksheets("Want_Full").Cells(n, 1) = "X" Then
Worksheets("Want_Full").Range(Cells(n, 1), Cells(n, 7)).Copy Destination:=Worksheets("Want_Now").Range("A65536").End(xlUp).Offset(1, 0)
If Worksheets("Want_Now").Cells(n, 1) <> "X" Then Worksheets("Want_Now").Rows(n).Delete 'shift:=xlShiftUp
Else
End If
Next r
End Sub
Thanks again for responding. JSW
Field:=11, Criteria1:="x"
