MrExcel Publishing
Your One Stop for Excel Tips & Solutions

Copy/paste non-contiguous cells-but same row -- into diff wrksht,sme workbk - nxt empty row

Posted by Laura leigh on January 25, 2002 12:39 PM

I have a workbook that I am having some MAJOR work redundacnies on and I can't (for the life of me) find
out how to do this simple task.

here goes...
I have a row where the last column asks a question-
answer is Y or N. If the answer is y, then I want the
code to copy the values(in the same row) from columns a, b, e, h, and l. Then paste them into sheet3.
We'll call the first worksheet: sheet1(for testing purposes). I know that using Ctrl to select non-contiguous cells in Excel - then - copying/pasting them puts them contiguously into the pasted locations. That's what I want to happen, so no prob.
It will go into the next empty row & start @ column A is fine!

Please, can anyone help?????
Thank you SO - So - SO MUCH!!


Posted by Joe Was on January 25, 2002 2:41 PM

I did not have time to taylor this code to your needs, but it is commented and just about does what you want. You need to change the sheet names to yours, the copy flag is "X" and not your "y" the code copies a row range, you need individual cells, a quick change. Just re-do the copy/paste block for each additional range. 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.

Application.ScreenUpdating = False
For Each r In Worksheets("Want_Full").UsedRange.Rows
n = r.Row
'"Want_Full" is the first sheet, the number in "Cells" is the column of the test.
If Worksheets("Want_Full").Cells(n, 1) = "X" Then
Worksheets("Want_Full").Range(Cells(n, 2), Cells(n, 7)).Copy Destination:=Worksheets("Want_Now").Range("B65536").End(xlUp).Offset(1, -1)
End If
Next r
'This optional code replaces the copy flag, like a re-set.
Worksheets("Want_Full").Columns("A").Replace What:="X", Replacement:="*", SearchOrder:=xlByColumns, MatchCase:=True

ActiveWindow.ScrollRow = 22
ActiveWindow.SmallScroll Down:=19

ActiveWindow.ScrollRow = 1

Range("B65536").End(xlUp).Offset(2, -1).Select
Application.ScreenUpdating = True

End Sub