Copy cells from different columns on same row, and paste to different columns on same row on another sheet

Question

I have successfully written code that will copy a cell, paste into a cell on another page and then wash rinse repeat for 3 other columns. See below:

Sub Click()

Dim amattuid As String
Dim finalrow As Integer
Dim i As Integer


Application.ScreenUpdating = False

Sheets("Buckhalter VB").Range("A6:G200").ClearContents

amattuid = Sheets("Buckhalter VB").Range("B3").Value
finalrow = Sheets("Current Heirarchy").Range("BM2000").End(xlUp).Row
repattuid = Sheets("Buckhalter VB").Range("A6").Value

For i = 4 To finalrow
    If Sheets("Current Heirarchy").Cells(i, 65) = amattuid Then
        Sheets("Current Heirarchy").Cells(i, 46).Copy
        Sheets("Buckhalter VB").Range("A200").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        Sheets("Current Heirarchy").Cells(i, 2).Copy
        Sheets("Buckhalter VB").Range("B200").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        Sheets("Current Heirarchy").Cells(i, 48).Copy
        Sheets("Buckhalter VB").Range("C200").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        Sheets("Current Heirarchy").Cells(i, 49).Copy
        Sheets("Buckhalter VB").Range("G200").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
Next i

Application.ScreenUpdating = True

End Sub

This works, but I am wondering if there is a way to streamline it. So it copies all of the cells at once, and then pastes them out at once into the designated locations.

Answer 1

Try this :

Sub Click()

Dim amattuid As String
Dim finalrow As Integer
Dim i As Integer


Application.ScreenUpdating = False

Sheets("Buckhalter VB").Range("A6:G200").ClearContents

amattuid = Sheets("Buckhalter VB").Range("B3").Value
finalrow = Sheets("Current Heirarchy").Range("BM2000").End(xlUp).Row
repattuid = Sheets("Buckhalter VB").Range("A6").Value

For i = 4 To finalrow
    If Sheets("Current Heirarchy").Cells(i, 65) = amattuid Then
        Sheets("Buckhalter VB").Range("A200").End(xlUp).Offset(1, 0) = Sheets("Current Heirarchy").Cells(i, 46).Value
        Sheets("Buckhalter VB").Range("B200").End(xlUp).Offset(1, 0) = Sheets("Current Heirarchy").Cells(i, 2).Value
        Sheets("Buckhalter VB").Range("C200").End(xlUp).Offset(1, 0) = Sheets("Current Heirarchy").Cells(i, 48).Value
        Sheets("Buckhalter VB").Range("G200").End(xlUp).Offset(1, 0) = Sheets("Current Heirarchy").Cells(i, 49).Value
        End If
Next i

Application.ScreenUpdating = True

End Sub