Search Engine VBA

I find this code better but i dont know how to have more columns in searching the fields and let more appears in the result..

Sub SearchParts()
 Dim arrParts() As Variant
    Range("A7", "B" & Cells(Rows.CountLarge, "B").End(xlDown).Row).Clear
    arrParts = FindParts(CStr(Trim(Cells(2, 2))))
    Range("A7").Resize(UBound(arrParts, 2), UBound(arrParts)) = _
        WorksheetFunction.Transpose(arrParts)
End Sub
Private Function FindParts(PartNumber As String) As Variant
Dim ws As Worksheet
Dim FoundCell As Range
Dim LastCell As Range
Dim rngParts As Range
Dim FirstAddr As String
Dim arrPart() As Variant

    Set ws = Worksheets("Data")
    Set rngParts = ws.Range("B2:B" & ws.Cells(Rows.CountLarge, "B").End(xlUp).Row)

    With rngParts
        Set LastCell = .Cells(.Cells.Count)
    End With

    Set FoundCell = rngParts.Find(What:=PartNumber, After:=LastCell, LookAt:=xlPart)

    If Not FoundCell Is Nothing Then
        FirstAddr = FoundCell.Address
    End If
    
    ReDim arrPart(1 To 2, 1 To 1)
    Do Until FoundCell Is Nothing
        arrPart(1, UBound(arrPart, 2)) = FoundCell.Offset(0, -1)
        arrPart(2, UBound(arrPart, 2)) = FoundCell.Value
        
        ReDim Preserve arrPart(1 To 2, 1 To UBound(arrPart, 2) + 1)

        Set FoundCell = rngParts.FindNext(After:=FoundCell)
        If FoundCell.Address = FirstAddr Then
            Exit Do
        End If
    Loop
    FindParts = arrPart
End Function