Copy and paste a range of cells in a row based on a criteria in a specific cell

[JamesPa]

I'm having an issue and I'm hoping someone can help. I have code which will copy an entire row from "Sheet2" if the value in the cell in column Q is >0 and will paste it in "Sheet6". I do not need the entire row to be copied. I need the cells in columns B, C, D, E, F, G, H, Q and U to be copied from "Sheet2" an pasted into "Sheet6". Can someone show me the code to copy and paste the range of cells, rather than the entire row? Here is the code I am using, which works for copying the entire row.

Sub copyrows3()
Dim rng As Range
Dim cell As Range
Dim lr As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet

Set ws1 = Sheet2
Set ws2 = Sheet6

lr = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ws1.Range("q1:q" & lr)

For Each cell In rng
If cell.Value > 0 Then
cell.EntireRow.Copy
ws2.Select
If ws2.Range("A1").Value = "" Then
ws2.Range("a1").PasteSpecial xlPasteValues
Else
Cells((Cells(Rows.Count, "a").End(xlUp).Row) + 1, "a").PasteSpecial xlPasteValues
End If
End If
Next cell

Application.CutCopyMode = False
Range("A1").Select

End Sub


Thanks in advance for any help you can provide.

 

[EXCEL MAX]

Hello JamesPa, welcome.
Here is quick re edited code.
Hope it will be useful, and that you will understand the logic of selective copying.

Sub copyrows3()

    Dim rng As Range
    Dim cell As Range
    Dim lr As Long
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim vR As Long
    
    Application.ScreenUpdating = False
    Set ws1 = Sheets("Sheet2")
    Set ws2 = Sheets("Sheet6")
    lr = ws1.Cells(Rows.Count, 17).End(xlUp).Row
    Set rng = ws1.Range("Q1:Q" & lr)
    For Each cell In rng
        If cell.Value > 0 Then
            vR = cell.Row
            With ws1
                Union(.Range(.Cells(vR, 2), .Cells(vR, 8)), _
                      .Cells(vR, 17), .Cells(vR, 21)).Copy
            End With
            With ws2
                If .Range("A1").Value = "" Then
                    .Range("Q" & vR).PasteSpecial xlPasteValues
                Else
                    .Cells((Cells(Rows.Count, "A").End(xlUp).Row) + 1, "A"). _
                    PasteSpecial xlPasteValues
                End If
            End With
        End If
    Next cell
    ws2.Activate
    Range("Q1").Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

 

[JamesPa]

Hello JamesPa, welcome.
Here is quick re edited code.
Hope it will be useful, and that you will understand the logic of selective copying.

Sub copyrows3()

    Dim rng As Range
    Dim cell As Range
    Dim lr As Long
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim vR As Long
   
    Application.ScreenUpdating = False
    Set ws1 = Sheets("Sheet2")
    Set ws2 = Sheets("Sheet6")
    lr = ws1.Cells(Rows.Count, 17).End(xlUp).Row
    Set rng = ws1.Range("Q1:Q" & lr)
    For Each cell In rng
        If cell.Value > 0 Then
            vR = cell.Row
            With ws1
                Union(.Range(.Cells(vR, 2), .Cells(vR, 8)), _
                      .Cells(vR, 17), .Cells(vR, 21)).Copy
            End With
            With ws2
                If .Range("A1").Value = "" Then
                    .Range("Q" & vR).PasteSpecial xlPasteValues
                Else
                    .Cells((Cells(Rows.Count, "A").End(xlUp).Row) + 1, "A"). _
                    PasteSpecial xlPasteValues
                End If
            End With
        End If
    Next cell
    ws2.Activate
    Range("Q1").Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

That did the trick!! Thank you very much for your assistance! It’s greatly appreciated.

 

[EXCEL MAX]

You are welcome. Thanks for feedback.

 

[Sdwd76]

Hi i have tried to used this but having issues?

I am trying to find the word Level in column CI in sheet 2

if this is found then copy cells B, BN , BM, BP , BO into sheet 6

I would like the first entry to start from row 2, column B in sheet 6

thanks in advance