Hi Lisa,

Yes, you would additional part numbers to this line...

If CStr(rngCell) = "3519" Then
...like so for additional part numbers (you can have up to 30 individual part numbers):

If CStr(rngCell) = "3501" Or CStr(rngCell) = "3519" Then
Or you can use the following where each part number is separated by a comma ie 3519 for one part number or 3519,3501 for two (or how ever many part numbers you want) via the Inputbox function from the PartNumSelection macro:

Option Explicit
Sub PartNumSelection()

    Dim strMyArray() As String
    Dim intArrayItem As Integer
    
    strMyArray() = Split(InputBox("Enter the desired part number(s) each separated with a comma:", "Part Number Selection"), ",")
    
    'Quit if the <Cancel> button has been pressed
    If Len(Join(strMyArray)) = 0 Then Exit Sub
    
    Application.ScreenUpdating = False
    
    For intArrayItem = LBound(strMyArray) To UBound(strMyArray)
        PartNumExtraction (CStr(strMyArray(intArrayItem)))
    Next intArrayItem
    
    Application.ScreenUpdating = True
    
    MsgBox "Process complete.", vbInformation

End Sub
Sub PartNumExtraction(strPartNum As String)

    Const lngStartRow As Long = 2 'Starting row number for the data. Change to suit.

    Dim rngCell As Range
    Dim varAccNum As Variant
    Dim lngMyRow As Long, _
        lngEndRow As Long, _
        lngPasteRow As Long
        
    lngEndRow = Sheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row

    For Each rngCell In Sheets("Sheet1").Range("C" & lngStartRow, Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp))
        If CStr(rngCell) = strPartNum Then
            varAccNum = rngCell.Offset(0, -2)
            For lngMyRow = lngStartRow To lngEndRow
                If Sheets("Sheet1").Range("A" & lngMyRow) = varAccNum Then
                    On Error Resume Next 'Account for there being no data in Sheet2
                        lngPasteRow = Sheets("Sheet2").Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                        If lngPasteRow = 0 Then lngPasteRow = lngStartRow
                    On Error GoTo 0
                    Sheets("Sheet1").Range("A" & lngMyRow & ":C" & lngMyRow).Copy Destination:=Sheets("Sheet2").Range("A" & lngPasteRow)
                End If
            Next lngMyRow
        End If
    Next rngCell

End Sub
Regards,

Robert