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!

 

[My Aswer Is This]

Glad I was able to help you. Come back here to Mr. Excel next time you need additional assistance.

Perfect!

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

B

 

[rlindfi]

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

Hi,
This code is super useful for what I have been looking to do.
I am trying to adjust the code so it also copies over blank entries and duplicate columns? I cannot find a way to do this and would be so grateful for some guidance.
Thanks.