VBA Copy entire row then paste values

[JonathanOTAX]

Hello, I have this script;

Sub copyrows()
 Dim tfCol As Range, Cell As Object
 
 Set tfCol = Range("G2:G999")
 
    For Each Cell In tfCol
      
      If Cell = "" Then
      ElseIf Cell.Value = 0 Then
         Cell.EntireRow.Copy
         Sheet4.Select
         ActiveSheet.Range("A65536").End(xlUp).Select
         Selection.Offset(1, 0).Select
         ActiveSheet.Paste
      Else
         Cell.EntireRow.Copy
         Sheet2.Select
         ActiveSheet.Range("A65536").End(xlUp).Select
         Selection.Offset(1, 0).Select
         ActiveSheet.Paste
      End If
      
   Next
End Sub

However, I need to paste values. I tried simply shanging it to;

Sub copyrows()
 Dim tfCol As Range, Cell As Object
 
 Set tfCol = Range("G2:G999")
 
    For Each Cell In tfCol
      
      If Cell = "" Then
      ElseIf Cell.Value = 0 Then
         Cell.EntireRow.Copy
         Sheet4.Select
         ActiveSheet.Range("A65536").End(xlUp).Select
         Selection.Offset(1, 0).Select
         ActiveSheet.PasteSpecial xlPasteValues
      Else
         Cell.EntireRow.Copy
         Sheet2.Select
         ActiveSheet.Range("A65536").End(xlUp).Select
         Selection.Offset(1, 0).Select
         ActiveSheet.PasteSpecial xlPasteValues
      End If
      
   Next
End Sub

However, I get this error when I run it;

Any help would be appreciated.

 

[mumps]

Try:

Sub copyrows()
    Application.ScreenUpdating = False
    Dim tfCol As Range, Cell As Object
    Set tfCol = Range("G2:G999")
       For Each Cell In tfCol
         If Cell = "" Then
         ElseIf Cell.Value = 0 Then
            Cell.EntireRow.Copy
            Sheet4.Cells(Sheet4.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
         Else
            Cell.EntireRow.Copy
            Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
         End If
      Next
      Application.CutCopyMode = False
      Application.ScreenUpdating = True
End Sub

 

[Fluff]

How about

Sub copyrows()
 Dim tfCol As Range, Cell As Object
 
 Set tfCol = Range("G2:G999")
 
    For Each Cell In tfCol
      
      If Cell = "" Then
      ElseIf Cell.Value = 0 Then
         Cell.EntireRow.Copy
         Sheet4.Range("A65536").End(xlUp).Offset(1).PasteSpecial xlPasteValues
      Else
         Cell.EntireRow.Copy
         Sheet2.Range("A65536").End(xlUp).Offset(1).PasteSpecial xlPasteValues
      End If
      
   Next
End Sub