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

JamesPa

New Member
Joined
Dec 23, 2020
Messages
6
Office Version
  1. 2016
Platform
  1. Windows
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 Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.

EXCEL MAX

Active Member
Joined
Nov 11, 2020
Messages
392
Office Version
  1. 2016
Platform
  1. Windows
Hello JamesPa, welcome.
Here is quick re edited code.
Hope it will be useful, and that you will understand the logic of selective copying.
VBA Code:
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
 
Last edited:
Solution

JamesPa

New Member
Joined
Dec 23, 2020
Messages
6
Office Version
  1. 2016
Platform
  1. Windows
Hello JamesPa, welcome.
Here is quick re edited code.
Hope it will be useful, and that you will understand the logic of selective copying.
VBA Code:
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

Active Member
Joined
Nov 11, 2020
Messages
392
Office Version
  1. 2016
Platform
  1. Windows
You are welcome. Thanks for feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,130,112
Messages
5,640,173
Members
417,129
Latest member
geekzilla

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
Top