Copy certain columns to another worksheet based on criteria of another column

[TU5JP4]

Hi all,

I've searched countless previous threads on this brilliant site, unfortunately I've not been able to get them to work in file (serious skills shortage!).

I need to run a report macro from a button in a sheet, VBA calls it Sheet2, which has 23 columns of data (B - X). If column G in each row contains "Yes", I want it to copy the contents of columns F, H, M, O, R and S of the first row of data (row 6), and then paste them in Sheet1 starting in Cell B6.

Sheet1 only contains the columns listed above, so the data needs to paste in with no gaps where the other columns were in Sheet2. I then need the code to loop to iterate this down all rows in Sheet2 (there will likely never be more than around 50, but a code to run until the final row containing data would be ideal if possible). The last piece is each time the macro is run, all previous data will need to be deleted in Sheet1 before new data is copied across from Sheet2, so that the report doesnt carry over old data.

I hope that makes sense. I'm unsure if best to reference sheets by their numeric reference or by their given name, please use whichever approach is best and I can adjust.

Thanks so much in advance to anyone who can help!

 

[alansidman]

copy the contents of columns F, H, M, O, R and S of the first row of data (row 6), and then paste them in Sheet1 starting in Cell B6.

confused. Copying only this line of data. Is that what you really want. Please clarify. What is the point?

 

[TU5JP4]

Thanks for your reply Alan - the output is to create a report. I need to copy all rows with data, which also contain "Yes" in column G. But only the contents of columns F, H, M, O, R and S of each row. Sheet1, the output these are being copied to, is a report of critical information from the original sheet, Sheet2. These are the only columns we want copied as it is a high level report.

 

[TU5JP4]

A cheeky bump before the weekend! Massive thanks in advance to anyone who can help or point me in the right direction.

 

[My Aswer Is This]

Try this:

Sub Test()
' Modified 11-17-17 11:59 AM EST
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Sheets("Sheet2").Activate
Sheets("Sheet1").Cells.Clear
Lastrow = Sheets("Sheet2").Cells(Rows.Count, "G").End(xlUp).Row
Dim Lastrowa As Long
Lastrowa = 6
    For i = 6 To Lastrow
        If Cells(i, "G").Value = "Yes" Then
            Application.Union(Cells(i, "F"), Cells(i, "H"), Cells(i, "M"), Cells(i, "O"), Cells(i, "R"), Cells(i, "S")).Copy Destination:=Sheets(1).Range("B" & Lastrowa)
            Lastrowa = Lastrowa + 1
        End If
    Next
Application.ScreenUpdating = True
End Sub

 

[TU5JP4]

Brilliant, thanks MAIT!

I've put this in and ran it from a button in Sheet2, and I get a 'Subscript out of Range' error. Do I need to adjust it?

Thanks so much for you help, it's greatly appreciated!

 

[My Aswer Is This]

Do you have two sheets named like this:
"Sheet2"
"Sheet1"

That's what you said in your post

 

[TU5JP4]

Sorry, Friday brain!

Those are VBA''s names for them on the left hand list, their titles are Risks (Sheet2) and Risk Report (Sheet1).

I've updated the references within "" accordingly, and now get a 400 error if I run it from the button, or a 1004 error (Application defined or object defined error) if I run it directly through the VBA screen.

Apologies, this is all very new to me!

 

[My Aswer Is This]

You see the script I wrote here.

If the sheet names are not correct then modify them to meet your needs
See sheet names marked in Red

Sub Test()
' Modified 11-17-17 11:59 AM EST
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Sheets("[COLOR=#ff0000]Sheet2[/COLOR]").Activate
Sheets("[COLOR=#ff0000]Sheet1[/COLOR]").Cells.Clear
Lastrow = Sheets("[COLOR=#ff0000]Sheet2[/COLOR]").Cells(Rows.Count, "G").End(xlUp).Row
Dim Lastrowa As Long
Lastrowa = 6
    For i = 6 To Lastrow
        If Cells(i, "G").Value = "Yes" Then
            Application.Union(Cells(i, "F"), Cells(i, "H"), Cells(i, "M"), Cells(i, "O"), Cells(i, "R"), Cells(i, "S")).Copy Destination:=Sheets("[COLOR=#ff0000]Sheet1"[/COLOR]).Range("B" & Lastrowa)
            Lastrowa = Lastrowa + 1
        End If
    Next
Application.ScreenUpdating = True
End Sub

 

[TU5JP4]

Perfect!

Thanks again for your efforts and patience, you've saved me a long weekend.

B