Copy...Paste...by Macro!

Hi,

I am writing a macro. It should enable to copy rows ( i presented) that satisfy .Cells(i.11)>0 and .Cells(i,2)>.Cells(3.17) among rows(4:307), and paste them to rows (j presented) with the first cell blank.

My wrong macro is as follows:

Sub Datatransfer()
With ActiveSheet
For i = 4 To 307
For j = 309 To 400
If .Cells(i, 11) > 0 And .Cells(i, 2) > .Cells(3, 17) Then
Rows(i).Select
Selection.Copy
If .Cells(j, 1) = 0 Then
Rows(j).Select
ActiveSheet.Paste
End If
End If
Next
Next
End With
End Sub

The problem is that the macro only keeps copying the first row that satisfies the criteria from rows(4:307) to all rows among rows(309:400) with the first cell blank.

any helps & tips are appreciated here. Thanks!

myf1

Answer this question

Copy...Paste...by Macro!

Crof
You just need to take out the j For loop and instead keep track of the destination row. See if the following does what you want:

Sub Datatransfer2()
With ActiveSheet
destrow = 309
For i = 4 To 307
If .Cells(i, 11) > 0 And .Cells(i, 2) > .Cells(3, 17) Then
Rows(i).Select
Selection.Copy
If .Cells(destrow, 1) = 0 Then
Rows(destrow).Select
ActiveSheet.Paste
destrow = destrow + 1
End If
End If
Next
End With
End Sub

Also you don't need to select a range before copying and the same with pasting, as the above does. Copying and pasting can be done in one operation if you use a Range object:

Sub Datatransfer3()
Dim rng As Range
With ActiveSheet
destrow = 309
For i = 4 To 307
If .Cells(i, 11) > 0 And .Cells(i, 2) > .Cells(3, 17) Then
If .Cells(destrow, 1) = 0 Then
Set rng = Rows(destrow)
Rows(i).Copy Destination:=rng
destrow = destrow + 1
End If
End If
Next
End With
Set rng = Nothing
End Sub
Copy...Paste...by Macro!

Answer this question