复制同一行中不同列的单元格，并粘贴到另一个工作表上同一行的不同列

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