(VBA) Copy not EntireRow

Robert Mika

Robert Mika

MrExcel MVP
Joined
Jun 29, 2009
Messages
7,256
The Code below copies entire row based on condition.
How to change the red part to copy only columns B-Y for each row where condition match.
Code: 
Sub copyrows1()
     
    Dim tfCol As Range, cell As Object
     
    Set tfCol = Range("A3:A1700")       
    For Each cell In tfCol
         
        If IsEmpty(cell) Then
            Exit Sub
        End If
         Application.ScreenUpdating = False
        If cell.Value = "Robert" Then
            cell.[COLOR=#ff0000]EntireRow[/COLOR].Copy
            Sheet3.Select
            ActiveSheet.Range("A65536").End(xlUp).Select
            Selection.Offset(1, 0).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
 
        End If
         
    Next
     End Sub
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
Sort by date Sort by votes
Try

Intersect(cell.EntireRow,Columns("B:Y")).Copy
 
Upvote 0
Code: 
Sub copyrows1()
     
    Dim tfCol As Range, cell As Object
     
    Set tfCol = Range("A3:A1700")       
    For Each cell In tfCol
         
        If IsEmpty(cell) Then
            Exit Sub

        End If
         Application.ScreenUpdating = False
        If cell.Value = "Robert" Then
[COLOR=#ff0000]            r=cell.row
            range("B" & r & ":Y" & r).Copy[/COLOR]
            Sheet3.Select
            ActiveSheet.Range("A65536").End(xlUp).Select
            Selection.Offset(1, 0).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
 
        End If
         
    Next
     End Sub
 
Upvote 0
Robert Mika said:
The Code below copies entire row based on condition.
How to change the red part to copy only columns B-Y for each row where condition match.
Code: 
Sub copyrows1()
     
    Dim tfCol As Range, cell As Object
     
    Set tfCol = Range("A3:A1700")       
    For Each cell In tfCol
         
        If IsEmpty(cell) Then
            Exit Sub
        End If
         Application.ScreenUpdating = False
        If cell.Value = "Robert" Then
            cell.[COLOR=#ff0000]EntireRow[/COLOR].Copy
           [COLOR="#0000CD"] Sheet3.Select
            ActiveSheet.Range("A65536").End(xlUp).Select
            Selection.Offset(1, 0).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False[/COLOR]
 
        End If
         
    Next
     End Sub
Click to expand...
Robert

Instead of all that Selecting in the blue part, could I also suggest this single line?
Rich (BB code): 
Sheet3.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial _
  Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

.. and Dim cell as Range


Edit: And good practice to turn ScreenUpdating back on. It does matter in later versions of Excel.
 
Last edited:
Upvote 0
Thank you patel45 and Peter - I used your improvements.

Peter,

is Object more resources consuming than Range or is a "good practise"?

I have added the ScreeUpdating too.
 
Upvote 0
Robert Mika said:
Peter,

is Object more resources consuming than Range or is a "good practise"?
Click to expand...
I'm not sure about resources, but to me it is more precise. A cell is a range and a range is an object.
I guess the analogy I can think of (hope you are a bit into geometry :)) is if you had a 4-sided shape with all 4 sides equal in length and all right angled corners, would you call it a polygon, a quadrilateral, a parallelogram, a trapezium, a rhombus, a rectangle or a square?
All of those names are correct, but the most precise name is square.
 
Upvote 0
Hello
I have the same problem, based on this code I would like to copy just selected cells in a row, for example column B, C and D in selected row.

Code:
Sub test()
Dim i, LastRow
LastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet2").Range("A2:K200").ClearContents
For i = 2 To LastRow
If Sheets("sheet1").Cells(i, "X").Value = "1" Then
Sheets("Sheet1").Cells(i, "X").EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
End Sub

Thank you for your help!
 
Upvote 0
Try replacing...

Code: 
Sheets("Sheet1").Cells(i, "X").EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)

with

Code: 
Sheets("Sheet1").Range(Cells(i, "B"),Cells(i,"D")).Copy Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)

for example column B, C and D in selected row
Click to expand...
Obviously the code you posted has no selection, the rows are decided by the i variable
 
Last edited:
Upvote 0
hi I have the same issue and I have tried the above solution but I am getting "Run time error 1004" Can you PLEASE HELP :) Initially I was using .entirerow.copy instead of Range(Cells... but I only need to copy columns S to W. Thanks.

Here is my entire code:

Private Sub Workbook_Open()

Worksheets("Summary").Activate

Dim i, LastRow

Sheets("BFM").Range("A2:W1000").ClearContents
Sheets("CFO").Range("A2:W1000").ClearContents
Sheets("EGM").Range("A2:W1000").ClearContents
Sheets("IFM").Range("A2:W1000").ClearContents
Sheets("JFM").Range("A2:W1000").ClearContents
Sheets("KFM").Range("A2:W1000").ClearContents
Sheets("LS").Range("A2:W1000").ClearContents
Sheets("MFM").Range("A2:W1000").ClearContents
Sheets("NGM").Range("A2:W1000").ClearContents
Sheets("OGM").Range("A2:W1000").ClearContents
Sheets("PFM").Range("A2:W1000").ClearContents
Sheets("TFM").Range("A2:W1000").ClearContents
Sheets("WGM").Range("A2:W1000").ClearContents
Sheets("XDD").Range("A2:W1000").ClearContents

LastRow = Sheets("table").Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To LastRow

If Sheets("table").Cells(i, "A").Value = "BFM Int'l Business (Chief Trade Commiss)" Then
Sheets("table").Range(Cells(i, "A"), Cells(i, "W")).Copy Destination:=Sheets("BFM").Range("A" & Rows.Count).End(xlUp).Offset(1)

End If

If Sheets("table").Cells(i, "A").Value = "Chief Financial Officer Branch" Then
Sheets("table").Range(Cells(i, "A"), Cells(i, "W")).Copy Destination:=Sheets("CFO").Range("A" & Rows.Count).End(xlUp).Offset(1)

End If

If Sheets("table").Cells(i, "A").Value = "EGM Europe, Middle East and Maghreb" Then
Sheets("table").Range(Cells(i, "A"), Cells(i, "W")).Copy Destination:=Sheets("EGM").Range("A" & Rows.Count).End(xlUp).Offset(1)

End If

If Sheets("table").Cells(i, "A").Value = "IFM Int'l Security & Political Affairs" Then
Sheets("table").Range(Cells(i, "A"), Cells(i, "W")).Copy Destination:=Sheets("IFM").Range("A" & Rows.Count).End(xlUp).Offset(1)

End If

If Sheets("table").Cells(i, "A").Value = "JFM Consular, Security and Legal" Then
Sheets("table").Range(Cells(i, "A"), Cells(i, "W")).Copy Destination:=Sheets("JFM").Range("A" & Rows.Count).End(xlUp).Offset(1)

End If

If Sheets("table").Cells(i, "A").Value = "KFM Partnership for Develop. Innovation" Then
Sheets("table").Range(Cells(i, "A"), Cells(i, "W")).Copy Destination:=Sheets("KFM").Range("A" & Rows.Count).End(xlUp).Offset(1)

End If

If Sheets("table").Cells(i, "A").Value = "Legal Services" Then
Sheets("table").Range(Cells(i, "A"), Cells(i, "W")).Copy Destination:=Sheets("LS").Range("A" & Rows.Count).End(xlUp).Offset(1)

End If

If Sheets("table").Cells(i, "A").Value = "MFM Global Issues and Development" Then
Sheets("table").Range(Cells(i, "A"), Cells(i, "W")).Copy Destination:=Sheets("MFM").Range("A" & Rows.Count).End(xlUp).Offset(1)

End If

If Sheets("table").Cells(i, "A").Value = "NGM Americas" Then
Sheets("table").Range(Cells(i, "A"), Cells(i, "W")).Copy Destination:=Sheets("NGM").Range("A" & Rows.Count).End(xlUp).Offset(1)

End If

If Sheets("table").Cells(i, "A").Value = "OGM Asia Pacific" Then
Sheets("table").Range(Cells(i, "A"), Cells(i, "W")).Copy Destination:=Sheets("OGM").Range("A" & Rows.Count).End(xlUp).Offset(1)

End If

If Sheets("table").Cells(i, "A").Value = "PFM Strategic Policy" Then
Sheets("table").Range(Cells(i, "A"), Cells(i, "W")).Copy Destination:=Sheets("PFM").Range("A" & Rows.Count).End(xlUp).Offset(1)

End If

If Sheets("table").Cells(i, "A").Value = "TFM Trade Agreements and Negotiations" Then
Sheets("table").Range(Cells(i, "A"), Cells(i, "W")).Copy Destination:=Sheets("TFM").Range("A" & Rows.Count).End(xlUp).Offset(1)

End If

If Sheets("table").Cells(i, "A").Value = "WGM Sub-Saharan Africa" Then
Sheets("table").Range(Cells(i, "A"), Cells(i, "W")).Copy Destination:=Sheets("WGM").Range("A" & Rows.Count).End(xlUp).Offset(1)

End If

If Sheets("table").Cells(i, "A").Value = "XDD Office of Protocol" Then
Sheets("table").Range(Cells(i, "A"), Cells(i, "W")).Copy Destination:=Sheets("XDD").Range("A" & Rows.Count).End(xlUp).Offset(1)

End If

Next i

End Sub
 
Upvote 0
akbercan said:
If Sheets("table").Cells(i, "A").Value = "BFM Int'l Business (Chief Trade Commiss)" Then
Sheets("table").Range(Cells(i, "A"), Cells(i, "W")).Copy Destination:=Sheets("BFM").Range("A" & Rows.Count).End(xlUp).Offset(1)

End If
Click to expand...
The following comment applies throughout your code, but I will show you the problem using the snippet I pulled from the code you posted... the two Cell calls I highlighted in red above both refer to the active worksheet, but the sheet you apparently want them to come from is named "table"... you must explicitly reference the worksheet you want them to come from like this (as shown in blue below)...

Code: 
[table="width: 500"]
[tr]
	[td]If Sheets("table").Cells(i, "A").Value = "BFM Int'l Business (Chief Trade Commiss)" Then
  Sheets("table").Range([B][COLOR="#0000FF"]Sheets("table").[/COLOR][/B]Cells(i, "A"), [B][COLOR="#0000FF"]Sheets("table").[/COLOR][/B]Cells(i, "W")).Copy Destination:=Sheets("BFM").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If[/td]
[/tr]
[/table]

Alternately, you can make things more readable (in my opinion) by using a With..EndWith block (be sure to note the leading dots)...

Code: 
[table="width: 500"]
[tr]
	[td]With Sheets("table")
  If .Cells(i, "A").Value = "BFM Int'l Business (Chief Trade Commiss)" Then
    .Range(.Cells(i, "A"), .Cells(i, "W")).Copy Destination:=Sheets("BFM").Range("A" & Rows.Count).End(xlUp).Offset(1)
  End If
End With[/td]
[/tr]
[/table]
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Question
VBA Copy, Paste to Different Workbook, Save as then loop the action through slicer
Replies
1
Views
234
krisoey
K
S
  • Solved
Macro Not running
2 3
Replies
28
Views
640
Joe4
Joe4
gheyman
  • Solved
PastSpecial problem
Replies
3
Views
121
gheyman
gheyman
S
  • Question
Keep getting an "Error 1004: item could not be found in the OLAP cube" when applying the filter to pivot table
Replies
5
Views
362
RoryA
RoryA
L
  • Solved
VBA Not Working Correctly
Replies
7
Views
121
kevin9999
K

Forum statistics

Threads
1,203,644
Messages
6,056,525
Members
444,872
Latest member
agutt

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