VBA macro - specifying columns with copy paste.

Question

I have a partially working VBA macro which copies from one sheet 'AverageEarnings' to one of two ('SicknessRecordGraded', 'SicknessRecordUngraded') on condition that a string is found in column 41 ("GRADED", "UNGRADED").
I want the macro to copy values from columns B,C ('AverageEarnings') to columns A, B on the other sheets, from row 3.
At the moment it is copying columns B,C,D to columns A,B,C on the other sheet from row 3.
Furthermore, I am receiving far too many values from the initial sheet, of which there are 4957. Here is my macro.

Public Sub CopyRowsSickness()

' This macro will copy rows in AverageEarnings spreadsheet, to Sheet1 if Ungraded (Column AO) or to Sheet2 if Graded.

    ' Insert message box to warn user.
    If MsgBox("This could take some time. (5 - 10 mins). Proceed?", vbYesNo) = vbNo Then Exit Sub

    ' Select initial sheet to copy from
    Sheets("AverageEarnings").Select
    ' Find the last row of data - xlUp will check from the bottom of the spreadsheet up.
    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
    ' For loop through each row
    For x = 1 To FinalRow

        ThisValue = Cells(x, 41).Value    ' The value to check is located in Column AO or 41.

        If ThisValue = "UNGRADED" Then    ' If the value is Ungraded
            Cells(x, 2).Resize(5000, 3).Copy ' Resize from intial range.
            Sheets("SicknessRecordUngraded").Select    ' Specify first sheet to copy to.
             NextRow = Cells(3, 3).End(xlUp).Row + 1    '   <-- This line instead of next if you dont want paste over top.
            'NextRow = Cells.Row + 1
            ' Rows.Count, 1
            Cells(NextRow, 1).Select ' Find the next row.
            ActiveSheet.Paste ' Paste information.
            Sheets("AverageEarnings").Select 'Reselect sheet to copy from.

        ElseIf ThisValue = "GRADED" Then
            Cells(x, 2).Resize(5000, 3).Copy
            Sheets("SicknessRecordGraded").Select
            NextRow = Cells(3, 3).End(xlUp).Row + 1
            'NextRow = Cells.Row + 1 ' Increment row.
            ' Rows.Count, 1
            Cells(NextRow, 1).Select
            ActiveSheet.Paste
            Sheets("AverageEarnings").Select

        End If
    Next x
End Sub

I am aware the problem lies within the values of these two lines. I have amended them to a variety of different values, but have not managed to fix it yet. It seems to paste far more values than the existing in 'AverageEarnings'.

Cells(x, 2).Resize(5000, 3).Copy

NextRow = Cells(3, 3).End(xlUp).Row + 1

Answer 1

Before copying, you are resizing the Range to be copied to be 5000 rows by 3 columns:

Cells(x, 2).Resize(5000, 3).Copy

If you only want to copy data from columns B & C in this row, you should only need to Resize to 1 row by 2 columns:

Cells(x, 2).Resize(1, 2).Copy

Updated for comment about data always being pasted in Row 3. When pasting the data, the row is being identified as:

NextRow = Cells(3, 3).End(xlUp).Row + 1

This starts at Cell C3, moves up within the current region (as if pressing END + UP), then down 1 row. This means that if you have a title row in C2, followed by the data, you end up back at Cell C3 to paste the data. Assuming that there is nothing below your table, I'd suggest:

NextRow = Cells(1048576, 3).End(xlUp).Row + 1

This works up from the bottom to find the last row with data, then takes the cell below that. You may need to adjust the row value for the Cells property(1048576) according to how many rows are available in your version of Excel.