copy paste macro taking too long - need help

[CIREWH]

I am trying to get a macro working where it will search for rows highlighted a particular color on Sheet1 and then copy them over to Sheet2. However I quickly realized that the copy/paste route was not very efficient. I tried to get the .Value=.Value option working since that appears to be the recommended method but I was only able to get data from column A moved over, instead of Columns A:G for the particular row that I need. Any help would be greatly appreciated. I am sure I'm missing something silly here.

My original attempt w/ the copy and paste method but will take forever and eats up a ton of CPU usage:

Sub MigrateData()    
    Dim Lastcell As Range
    Dim i As Long
     
    Sheets("Sheet1").Select
     
    Set Lastcell = Cells.Find("*", Searchdirection:=xlPrevious)
   
    Application.ScreenUpdating = False


    If Not Lastcell Is Nothing Then
       
        For i = Lastcell.Row To 4 Step -1
            If (Cells(i, 1).Interior.Color = RGB(169, 223, 191)) Then
                Range("A" & i & ":G" & i).Copy
                    Sheets("Sheet2").Select
                    Cells(4 + Count, 1).Select
                    ActiveSheet.Paste
                    Sheets("Sheet1").Select
                Count = Count + 1
            End If
        Next i
    End If
    Application.ScreenUpdating = True
End Sub

My 2nd attempt with using the value method but I was only able to get data from column A of each row to move over. After looking at it I see that
"Sheets("Sheet2").Cells(4 + Count, 1).Value" is the reason for it only moving data over to column A but I am unsure how to type out the range properly w/ the counter(if someone can please help me with that):

Sub MigrateData2()    
    Dim Lastcell As Range
    Dim i As Long
     
    Sheets("Sheet1").Select
     
    Set Lastcell = Cells.Find("*", Searchdirection:=xlPrevious)
   
    Application.ScreenUpdating = False


    If Not Lastcell Is Nothing Then
        For i = Lastcell.Row To 4 Step -1
            If (Cells(i, 1).Interior.Color = RGB(169, 223, 191)) Then
                Sheets("Sheet2").Cells(4 + Count, 1).Value = Sheets("Sheet1").Range("A" & i & ":G" & i).Value
                Sheets("Sheet1").Select
                Count = Count + 1
            End If
        Next i
    End If
    Application.ScreenUpdating = True
End Sub

Thanks guys!

 

[yky]

You can copy and paste directly, instead of activating the destination then pasting. Check out the following link:

https://msdn.microsoft.com/en-us/library/office/ff837760.aspx

 

[My Aswer Is This]

Try this:

Sub Test()
'Modified 2/28/17 7:00 PM EST
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Dim Lastrowa As Long
Lastrowa = Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row
    For i = 1 To Lastrow
        If Cells(i, 1).Interior.Color = RGB(169, 223, 191) Then
            Range(Cells(i, 1), Cells(i, 7)).Copy Destination:=Sheets(2).Range("A" & Lastrowa)
            Lastrowa = Lastrowa + 1
        End If
    Next
Application.ScreenUpdating = True
End Sub