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:
Sort by date Sort by votes
MARK858 said:
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
Click to expand...


Many thanks Mark for taking the time to support with this, it's very much appreciated.

I'm attempting to move to the above, but hitting issues with the data being added to the Extract sheet but it deleting the headings (in row 4).

I've changed the (2) to (5) to become:

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

and it now adds the data from row 5 downward (versus row 2), but it's still overwriting (clearing) the headings in row 4.

Any ideas how I can get it to leave rows 1:4 well alone?

Many thanks,

Upex
 
Upvote 0

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
I don't get the issue with the code I posted if there is a header in G4 of Sheets("Extract").

Don't change the 2 to a 5 it is not a row number it is an item in a range (see below), basically the same as .Offset(1).

Cells Within Ranges
 
Last edited:
Upvote 0
MARK858 said:
I don't get the issue with the code I posted if there is a header in G4 of Sheets("Extract").

Don't change the 2 to a 5 it is not a row number it is an item in a range (see below), basically the same as .Offset(1).
Click to expand...

OK, thanks Mark. I've reset the 2 and its 'pasting' the data starting in G4 - very strange, as the Destination
Code: 
Range("G" & Rows.Count).End(xlUp)(2).[B]select[/B]
lands on G5 when run in isolation with select added so I could see what's going on), so appears the destination selection is correct as you say.

I'll review the other code I've got in there, but nothing should be shoving it all up a row.

Many thanks,
 
Last edited:
Upvote 0
Sussed it,

I was clearing the old data so that each time the 'yes' entries are copied across, it was starting a fresh, and I neglected to add in the offset(1) of:
Code: 
Sheets("extract").Range("g5:et" & Sheets("extract").Range("g" & Rows.Count).End(xlUp).Offset(1).Row).clearcontents

so it was deleting the headings when running on the sheet with no data (just headings) DOHH!

Thanks for the help Mark. May need to pop back regards the autofilter, as its knocked it off the Data sheet a few times and I want it to retain the autofilter across the row 4 headings. Will have a play and see if I can fix it.

Cheers, Upex
 
Upvote 0
Sussed it,

I was clearing the old data so that each time the 'yes' entries are copied across, it was starting a fresh, and I neglected to add in the offset(1) of:
Code: 
Sheets("extract").Range("g5:et" & Sheets("extract").Range("g" & Rows.Count).End(xlUp).[B]Offset(1).[/B]Row).clearcontents

so it was deleting the headings when running on the sheet with no data (just headings) DOHH!

Thanks for the help Mark. May need to pop back regards the autofilter, as its knocked it off the Data sheet a few times and I want it to retain the autofilter across the row 4 headings. Will have a play and see if I can fix it.

Cheers, Upex
 
Upvote 0
Upex said:
Thanks for the help Mark. May need to pop back regards the autofilter, as its knocked it off the Data sheet a few times and I want it to retain the autofilter across the row 4 headings. Will have a play and see if I can fix it.
Click to expand...

If you are saying you want the dropdown arrows to remain on the Data sheet then change it to
Code: 
Sub CopyYesRows2()
    Dim myCell As Range
    Application.ScreenUpdating = False

    With Sheets("Data").Range("[COLOR="#FF0000"]A1[/COLOR]:A0" & Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row)

        .AutoFilter 1, "Yes"
        Application.Intersect(.Offset(1), .Resize(.Rows.Count).SpecialCells(12), Sheets("Data").Columns("H:AO")).Copy _
                Destination:=Sheets("Extract").Range("G" & Rows.Count).End(xlUp)(2)
     End With
     [COLOR="#FF0000"]Sheets("Data").ShowAllData[/COLOR]
    
Application.ScreenUpdating = True
End Sub

Please note the range change as well as it should have been amended in the original code.
 
Last edited:
Upvote 0
OK, so I've been away and built the spreadsheet which uses the code Mark kindly supported, but I've had to tweak it a bit, as I've built the spready to delete all old data then add in the new data (that has been copied) always from G5, rather than adding it to the bottom, so I've ended up with a module that contains:

Code: 
    With Sheets("data").Range("A5:AO" & Sheets("data").Range("h" & Rows.Count).End(xlUp).Row)
        .AutoFilter 1, "Yes" 
        Application.Intersect(.Offset(0), .Resize(.Rows.Count).SpecialCells(12), Columns("H:AO")).Copy Destination:=Sheets("Extract").Range("G4")(2)
    End With

When the above is run on its own (just running that module with this in, or cutting just this code out and running separately), it works great.

However when I'm calling my entire code, I get an error, which highlights the line:
Code: 
Application.Intersect(.Offset(0), .Resize(.Rows.Count).SpecialCells(12), Columns("H:AO")).Copy Destination:=Sheets("Extract").Range("G4")(2)<strike></strike>

the error says:

Run-time error '1004':
Method 'Intersect' of object '_Application' failed

I can't understand this, I barely and rarely use VBA, but do not understand how it can work by F5-ing the module, but then fail when pressing the button which calls that module, and not much else (check active page, shows a userform, turns off screen updating and then calls the module which works on its own?)

Anyone any ideas please? as this is all that is wrong and once fixed, I'm finished.

In case it helps:

The button calls this module:

Code: 
Sub UpdateWorkBook_All()
If ActiveWorkbook.Worksheets("data") Is ActiveSheet Then
    usfRunning.Show vbModeless
    DoEvents
Application.ScreenUpdating = False
    Call Flags
    
    Call Rules
    

    Else
        Sheets("Data").Select
        
        Call UpdateWorkBook_All
End If
    Unload usfRunning
Application.ScreenUpdating = True
End Sub

The userform is literally just a message telling the user to wait for everything to be done.

The Flags module works fine, give correct results, no errors etc.

The Rules module is:

Code: 
Sub Rules()
    Dim TableOne, TableTwo As Range
    Dim RuleColumnSpan As String
        RuleColumnSpan = Split(Sheets("Extract").Range("at4").End(xlToRight).Address, "$")(1)
    
Application.ScreenUpdating = False
    With Sheets("Extract")
    
        If .AutoFilterMode = True Then
            .AutoFilterMode = False
            Else
        End If
        
        .Range("5:50000").Delete
        .Range("i3").ClearContents
        .Range("at3:" & RuleColumnSpan & "3").ClearContents
    End With
    
    Range("MR_Extract").Copy
        Sheets("Extract").Range("At4").PasteSpecial Paste:=xlPasteValues, Transpose:=True
        Sheets("Rule Overview").Range("Extract_rule_start").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
    Sheets("Extract").UsedRange
    
    With Sheets("Data").Range("A5:AO" & Sheets("Data").Range("h" & Rows.Count).End(xlUp).Row)
        .AutoFilter 1, "Yes"
        Application.Intersect(.Offset(0), .Resize(.Rows.Count).SpecialCells(12), Columns("H:AO")).Copy Destination:=Sheets("Extract").Range("G4")(2)
    End With
    
    Sheets("Data").ShowAllData
Set TableOne = Sheets("Extract").Range("g5:an" & Sheets("Extract").Range("g" & Rows.Count).End(xlUp).Offset(1).Row)
Set TableTwo = Sheets("Extract").Range("at5:" & RuleColumnSpan & Sheets("Extract").Range("g" & Rows.Count).End(xlUp).Offset(1).Row)
    
    TableTwo.Formula = "=IF(AND(ISNUMBER(FIND(R4C,RC13)),NOT(ISNUMBER(VALUE(MID(RC13,FIND(R4C,RC13)+LEN(R4C),1))))),""X"",IF(AND(ISNUMBER(FIND(R4C,RC14)),NOT(ISNUMBER(VALUE(MID(RC14,FIND(R4C,RC14)+LEN(R4C),1))))),""X"",""""))"
    With Sheets("Extract")
        .Range("at2:" & RuleColumnSpan & "3").Formula = "=IF(SUBTOTAL(103,AT$5:AT$50000)=0,"""",SUBTOTAL(103,AT$5:AT$50000))"
    
        .Range("at3:" & RuleColumnSpan & "3").Formula = "=IF(COUNTIF(AT$5:AT$50000,""X"")=0,"""",COUNTIF(AT$5:AT$50000,""X""))"
    
        .Range("i2").Formula = "=IF(SUBTOTAL(103,$H$5:$H$50000)=0,"""",SUBTOTAL(103,$H$5:$H$50000))"
        
        .Range("i3").Formula = "=IF(COUNTIF($H$5:$H$50000,""<""&"">""&"""")=0,"""",COUNTIF($H$5:$H$50000,""<""&"">""&""""))"
        
        .Calculate
        .Range("at3:" & RuleColumnSpan & "3").Value = Sheets("Extract").Range("at3:" & RuleColumnSpan & "3").Value
    
        .Range("i3").Value = Sheets("Extract").Range("i3").Value
    End With
    
    TableTwo.Value = TableTwo.Value
    Application.CutCopyMode = False
    Sheets("Extract").Range("G4:" & RuleColumnSpan & "4").AutoFilter

    With Sheets("Extract").Range("g4:" & RuleColumnSpan & Sheets("Extract").Range("g" & Rows.Count).End(xlUp).Row)
        .Borders(xlEdgeLeft).LineStyle = xlDouble
        .Borders(xlEdgeLeft).Weight = xlThick
        .Borders(xlEdgeRight).LineStyle = xlDouble
        .Borders(xlEdgeRight).Weight = xlThick
        .Borders(xlEdgeTop).LineStyle = xlDouble
        .Borders(xlEdgeTop).Weight = xlThick
        .Borders(xlEdgeBottom).LineStyle = xlDouble
        .Borders(xlEdgeBottom).Weight = xlThick
    End With
    
    With Sheets("Extract").Range("g4:" & RuleColumnSpan & "4")
        .Borders(xlEdgeBottom).LineStyle = xlDouble
        .Borders(xlEdgeBottom).Weight = xlThick
    End With
    
    With Sheets("Extract").Range("g2:i3")
        .Borders(xlEdgeLeft).LineStyle = xlDouble
        .Borders(xlEdgeLeft).Weight = xlThick
        .Borders(xlEdgeRight).LineStyle = xlDouble
        .Borders(xlEdgeRight).Weight = xlThick
        .Borders(xlEdgeTop).LineStyle = xlDouble
        .Borders(xlEdgeTop).Weight = xlThick
        .Borders(xlEdgeBottom).LineStyle = xlDouble
        .Borders(xlEdgeBottom).Weight = xlThick
        .Borders(xlInsideVertical).LineStyle = xlDash
        .Borders(xlInsideVertical).Weight = xlThin
    End With
    
    With Sheets("Extract").Range("AN2:" & RuleColumnSpan & "3")
        .Borders(xlEdgeLeft).LineStyle = xlDouble
        .Borders(xlEdgeLeft).Weight = xlThick
        .Borders(xlEdgeRight).LineStyle = xlDouble
        .Borders(xlEdgeRight).Weight = xlThick
        .Borders(xlEdgeTop).LineStyle = xlDouble
        .Borders(xlEdgeTop).Weight = xlThick
        .Borders(xlEdgeBottom).LineStyle = xlDouble
        .Borders(xlEdgeBottom).Weight = xlThick
    End With
    
    With Sheets("Extract").Range("an2:An3")
        .Borders(xlEdgeRight).LineStyle = xlDash
        .Borders(xlEdgeRight).Weight = xlThin
    End With
    With Sheets("Extract").Range("as2:As3")
        .Borders(xlEdgeRight).LineStyle = xlDash
        .Borders(xlEdgeRight).Weight = xlThin
    
    End With
    
End Sub


Not pretty I know, and I'll be looking at getting VBA to do the formula calcs and just enter them into the cells rather than adding, calculating and then pasting the values, but need to get the blooming thing working first lol.

Any ideas would be great.

Many thanks, Upex
 
Last edited:
Upvote 0
What happens if you put a period in front of Columns? i.e.

Code: 
[COLOR="#FF0000"].[/COLOR]Columns("H:AO"))
 
Upvote 0
MARK858 said:
What happens if you put a period in front of Columns? i.e.
Click to expand...

Well, I'll be... 4hrs faffing about for a blooming full stop!

Many many thanks for this, and all the previous help Mark, works as I wanted with that full stop in it.

Haven't a clue why it works without the full stop when run in isolation vs needing it as it's incorporated, but I'm a happy bunny now it's running.

Much appreciated.

Thanks, Upex
 
Upvote 0
Should have come back to this before (looked at it originally on my phone and forgot about it :oops:).

Anyway to answer

Haven't a clue why it works without the full stop when run in isolation vs needing it as it's incorporated
Click to expand...

If the full stop isn't there then it isn't linking to the With statement and so rather than referring to
Code: 
Sheets("Data").Range("A5:AO" & Sheets("Data").Range("h" & Rows.Count).End(xlUp).Row)

it is referring to the Activesheet. As you can't have an intersect between ranges on 2 different sheets you get the error.

Basically with a "With" statement on a line like

Code: 
Range("A1:A10").Copy

you are putting a line break where the | is in the line below

Code: 
Range("A1:A10")[COLOR="#FF0000"]|[/COLOR].Copy

so you get

Code: 
With Range("A1:A10")
     .Copy
End With

so you need the full stop.

Hope that makes sense.
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Question
Find last row of sheet based off cell value to reference the sheet name
Replies
0
Views
258
ItalianPlatinum
I
P
  • Question
Paste rows from another sheet
Replies
4
Views
336
Sam_D_Ben
S
T
  • Solved
Import Data Starting from next empty row
Replies
7
Views
119
Tanne
T
U
  • Solved
Macro Cell Range reference changes with the addition of New Rows in Active Sheet
Replies
4
Views
98
RobP
R
R
  • Solved
Ignoring the value of a formula in a cell.
Replies
8
Views
384
Royalbloodi
R

Forum statistics

Threads
1,216,488
Messages
6,130,952
Members
449,608
Latest member
jacobmudombe

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