Copy and paste to different sheet, secified column range from each row that meets a condition

U

Upex

Board Regular
Joined
Dec 29, 2010
Messages
186
Office Version
  1. 365
Platform
  1. Windows
Hi All,

I'm sure this has been done before, and likely out there a hundred times already, but for the life of me I can't find it.

I'm looking to copy columns H through to AO, from each row on the worksheet "Data" that has "Yes" in column A and then paste those ranges into the sheet called "Extract", building a list down from G5 (G4 has the heading).

I've got this thus far:

Code: 
Sub CopyYesRows()


For Each cell In Sheets("Data").Range("a:a")
    
    If cell.Value = "Yes" Then
        [B]Range(Cells(ActiveCell.Row, 8), Cells(ActiveCell.Row, 41)).Copy[/B]   '8=ColH  41=ColAO
        
            If Sheets("Extract").Range("g5") = "" Then
               Sheets("Extract").Range("g5").PasteSpecial
            
                Else: Sheets("Extract").Range("G4").End(xlDown).Offset(1, 0).PasteSpecial
            End If
    End If
Next
End Sub

But its not pulling through the data, just grabs the range from the row that was active before triggering the code - I believe due to reference to active row, where I'm not actually selecting/activating each row that has Yes in A:A.

How can I ditch the Activecell.row reference to be 'row on which you've found the Yes in A:A" as I'm keen to not have lots of selection going on. OR how else can I achieve the result please?

Many thanks in advance.

Upex
 
Last edited:

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
Sort by date Sort by votes
Sticking to a similar method try...

Code: 
Sub CopyYesRows()
    Dim myCell As Range
    Application.ScreenUpdating = False
    
    For Each myCell In Sheets("Data").Range("A2:A" & Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row)

        If myCell.Value = "Yes" Then
            Application.Intersect(myCell.EntireRow, Columns("H:AO")).Copy _
                    Sheets("Extract").Range("G" & Rows.Count).End(xlUp)(2)
        End If
    Next
    
    Application.ScreenUpdating = True
End Sub

Although it would be faster to use something like the autofilter fo the task.
 
Upvote 0
Many thanks Mark, that appears to work as needed.

MARK858 said:
Although it would be faster to use something like the autofilter fo the task.
Click to expand...

My first attempts were made using autofilter, but I couldn't get it to work, perhaps as Column A is filled with formula that check a few things to mark up the Yes's.

Many thanks for your help, I'm now off to try to figure out how to incorporate the formula into code, so it keeps it all clean and tidy and less prone to error etc. Perhaps once I've sussed that, I can re-look at the autofilter, although the spreadsheet will only even be circa 1500 rows, so not a lot of data to trawl through I guess.

Cheers, Upex
 
Last edited:
Upvote 0
Sorry Mark,

Just noticed that I do not understand how the values are being added/pasted to the Extract sheet - is that a feature of the applicaion.intersect bit? as appears to find the Yes, copy H to AO and then find the last row of 'Extract', but not 'add' the data - a copy without paste if you see what I mean?

It does paste it in, so not a functionally question, rather to try and educate me and solve the puzzle that is in my head!

Thanks,
 
Upvote 0
It uses destination rather than pastespecial (except you don't need to put in Destination), which basically uses 1 less clipboard and so is more efficient.
In long hand it is...

Code: 
Application.Intersect(myCell.EntireRow, Columns("H:AO")).Copy Destination:=Sheets("Extract").Range("G" & Rows.Count).End(xlUp)(2)
 
Upvote 0
MARK858 said:
It uses destination rather than pastespecial (except you don't need to put in Destination), which basically uses 1 less clipboard and so is more efficient.
In long hand it is...

Code: 
Application.Intersect(myCell.EntireRow, Columns("H:AO")).Copy Destination:=Sheets("Extract").Range("G" & Rows.Count).End(xlUp)(2)
Click to expand...

I see, so having copied something, its already looking for the place to stick it, pretty cool. I'll have a play around with this, many thanks for explaining.

Currently doing a lot of copy of formula cells and then paste values, so perhaps this may possibly lead to reduced typing.

Cheers for the help Mark, much appreciated.
 
Upvote 0
If you are pasting as Values then you can't use Destination but you can do a value = value which is faster than pastespecial.

Not in now but I will post some examples later.
 
Upvote 0
Do you mean like

Sheets("data").range("h1:ao100").value = Sheets("extract").range("h1:ao100").value

Type thing?

(On mobile now so the above may be utter rubbish lol)
 
Upvote 0
It is not rubbish, it is basically correct and OK for ranges where you know the size of the range in advance.
I will post something later for when you haven't worked it out.
 
Upvote 0
Based on the original question...

With autofilter (not as values)

Code: 
Sub CopyYesRows2()
    Dim myCell As Range
    Application.ScreenUpdating = False

    With Sheets("Data").Range("A2:ao" & Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row)

        .AutoFilter 1, "Yes"
        Application.Intersect(.Offset(1), .Resize(.Rows.Count).SpecialCells(12), Columns("H:AO")).Copy _
                Destination:=Sheets("Extract").Range("G" & Rows.Count).End(xlUp)(2)
        .AutoFilter
    End With

    Application.ScreenUpdating = True
End Sub

With values when you have worked out the destination range (not autofilter)
Code: 
Sub CopyYesRows3()
    Dim myCell As Range, myRow As Long
    Application.ScreenUpdating = False

    For Each myCell In Sheets("Data").Range("A2:A" & Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row)

        If myCell.Value = "Yes" Then
            myRow = Range("G" & Rows.Count).End(xlUp)(2).Row
            Sheets("Extract").Range(Sheets("Extract").Cells(myRow, "G"), Sheets("Extract").Cells(myRow, "AN")).Value = _
            Application.Intersect(myCell.EntireRow, Sheets("Data").Columns("H:AO")).Value
        End If
    Next

    Application.ScreenUpdating = True
End Sub

With values when you haven't worked out the destination range (not autofilter)


Code: 
Sub CopyYesRows4()
    Dim myCell As Range
    Application.ScreenUpdating = False

    For Each myCell In Sheets("Data").Range("A2:A" & Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row)

        If myCell.Value = "Yes" Then
            With Application.Intersect(myCell.EntireRow, Sheets("Data").Columns("H:AO"))
                Sheets("Extract").Cells(Sheets("Extract").Range("G" & Rows.Count).End(xlUp)(2).Row, "G").Resize(.Rows.Count, .Columns.Count).Value = .Value

            End With
        End If

    Next

    Application.ScreenUpdating = True
End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
Copy and Paste
2
Replies
14
Views
753
Anthony47
A
S
  • Solved
VBA Copy and Paste to different sheets based on conditions
Replies
1
Views
345
HighAndWilder
H
M
  • Question
VBA only copy data from one sheet that isn't already on another sheet
Replies
0
Views
489
mik1996
M
K
  • Question
insert new row and insert data validation.
2
Replies
10
Views
569
KingGoku
K
V
  • Question
VBA Code to copy rows from one sheet to another dynamically
2
Replies
11
Views
914
Joe4
Joe4

Forum statistics

Threads
1,214,832
Messages
6,121,849
Members
449,051
Latest member
excelquestion515

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top