VBA Copy Code is copying more than the cells needed

I have a workbook with two main worksheets (Sheet1 and Sheet2). Sheet1 has numerous rows and each row contains information relating to a student. The student name is the first cell in the row. Each row contains a dropdown list (Yes or No) on one of the fields. I am trying to create a code that is activated when the Yes in the row is selected and it will copy the student name from the first cell to Sheet2 in the next available cell that is empty in column A. I currently have a code that is almost working like I need, however when it copies it copies all of the students names that have Yes selected rather than just the row that is active. The code follows. Any help would be greatly appreciated.

Public Sub CopyRows()
    Sheets("Sheet1").Select
    ' Find the last row of data
    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
    ' Loop through each row
    For x = 4 To FinalRow
        ' Decide if to copy based on column H
        ThisValue = Cells(x, 8).Value
        If ThisValue = "YES" Then
            Cells(x, 1).Copy
            Sheets("Sheet2").Select
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Cells(NextRow, 1).Select
            ActiveSheet.Paste
            Sheets("Sheet1").Select

        End If
    Next x
End Sub