Move specific columns based on search criteria

Question

Sub Test3()

Dim LSearchRow As Integer
Dim LCopyToRow As Integer

On Error GoTo Err_Execute

'Start search in row 5
LSearchRow = 5

'Start copying data to row 2 in Sheet3 (row counter variable)
LCopyToRow = 2

While Len(Range("Y" & CStr(LSearchRow)).Value) > 0

    'If value in column Y = "84312570", copy entire row to Sheet3
    If Range("Y" & CStr(LSearchRow)).Value = "84312570" Then

        'Select row in MasterList to copy
        Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
        Selection.Copy

        'Paste row into Sheet3 in next row
        Sheets("Sheet3").Select
        Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
        ActiveSheet.Paste

        'Move counter to next row
        LCopyToRow = LCopyToRow + 1

        'Go back to MasterList to continue searching
        Sheets("MasterList").Select

    End If

    LSearchRow = LSearchRow + 1

Wend

'Position on cell A5
Application.CutCopyMode = False
Range("A5").Select

MsgBox "All matching data has been copied."

Exit Sub

Err_Execute:
    MsgBox "An error occurred."

End Sub

This finds specific values in Column Y and moves entire rows of corresponding information to individual worksheets.

I have two questions.

First, is there a way to specify only certain columns of information be moved to the individual sheets instead of moving the entire row?

Second, is there a way to pull information based off of only the last 4 digits of the number sequence in column Y? For example, above I would want to pull all rows whose number in column Y matched *2570.

Answer 1

Untested: edit arrColsToCopy to include the columns you want copied over

Sub Test3()

    Dim LCopyToRow As Long
    Dim LCopyToCol As Long
    Dim arrColsToCopy
    Dim c As Range, x As Integer

    On Error GoTo Err_Execute


    arrColsToCopy = Array(1, 2, 3, 5, 10, 15) 'which columns to copy ?
    Set c = Sheets("MasterList").Range("Y5") 'Start search in row 5
    LCopyToRow = 2  'Start copying data to row 2 in Sheet3

    While Len(c.Value) > 0

        'If value in column Y ends with "2570", copy to Sheet3
        If c.Value Like "*2570" Then

            LCopyToCol = 1
            For x = LBound(arrColsToCopy) To UBound(arrColsToCopy)

                 Sheets("Sheet3").Cells(LCopyToRow, LCopyToCol).Value = _
                                c.EntireRow.Cells(arrColsToCopy(x)).Value

                LCopyToCol = LCopyToCol + 1

            Next x

            LCopyToRow = LCopyToRow + 1 'next row

        End If

        Set c = c.Offset(1, 0)

    Wend

    'Position on cell A5
    Range("A5").Select

    MsgBox "All matching data has been copied."

    Exit Sub

Err_Execute:
        MsgBox "An error occurred."

End Sub