VBA Need a Nested Loop to shift columns [duplicate

Question

This question already has an answer here:

• VBA macro for copying conditional data to specific cells 5 answers

Not very experienced with coding VBA, but I would appreciate any help this matter. The code below runs fine; however logically, I feel like it could be written better. Anyone have suggestions?

Sub CopyValues()

  'Declare variables
   Dim Sourcedataws As Worksheet
   Dim WStotransfer As Worksheet

  'Declare counter variables
   Dim i As Integer
   Dim lastrow As Long

  'Declare sheet variables
   Set Sourcedataws = ThisWorkbook.Sheets("Source Data")
   Set WStotransferws = ThisWorkbook.Sheets("WStotransfer")

    lastrow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

  For i = 2 To lastrow

If Sourcedataws.Range("AA" & i).Value = "Condition" Then

    WStotransferws.Range("C18") = Sourcedataws.Range("A" & i).Value
    ActiveCell.Offset(0, 1).Select
    WStotransferws.Range("D18") = Sourcedataws.Range("A" & i).Value
    ActiveCell.Offset(0, 1).Select
    WStotransferws.Range("E18") = Sourcedataws.Range("A" & i).Value
    ActiveCell.Offset(0, 1).Select
    WStotransferws.Range("F18") = Sourcedataws.Range("A" & i).Value
    ActiveCell.Offset(0, 1).Select
    WStotransferws.Range("G18") = Sourcedataws.Range("A" & i).Value
    ActiveCell.Offset(0, 1).Select
    WStotransferws.Range("H18") = Sourcedataws.Range("A" & i).Value
    ActiveCell.Offset(0, 1).Select
    WStotransferws.Range("I18") = Sourcedataws.Range("A" & i).Value



End If

Next

End Sub

Answer 1

Try:

Sub CopyValues()

'Declare counter variables
Dim i As Integer, j as Integer, lastrow As Long
'Declare variables
Dim Sourcedataws As Worksheet, WStotransfer As Worksheet
'Declare sheet variables
Set Sourcedataws = ThisWorkbook.Sheets("Source Data")
Set WStotransferws = ThisWorkbook.Sheets("WStotransfer")

lastrow = Sourcedataws.Cells(Sourcedataws.Rows.Count, "A").End(xlUp).Row

WStotransferws.Range("C18:I18").ClearContents

For i = 2 To lastrow
    If WStotransferws.Range("I18").Value="" Then
        If Sourcedataws.Range("AA" & i).Value = "Condition" Then
            Sourcedataws.Range("A"&i).Copy 
            j=WStotransferws.Cells(18, WStotransferws.Columns.Count).End(xlToLeft).Column
            WStotransferws.Cells(18,j+1).PasteSpecial xlPasteValues
            End If
        Else
        End If
    Next i

End Sub