Refining Famous Search Engine

Well,

hello guys. I want to make this search engine code a little bit better. I have two main concerns:

1) If the user writes two or more words, e.g., sun moon the search engine will look for all the Data in column B with the word sun and/or moon. It means, instead of using the exactly word (sun moon) written in cells(2,2) it would search separately for each word.

2) This is far more important than the first one: I would like for similar words in the search engine. For example, if the user searches for sum it will return sun anyway, because the words are very similar. But the question is: what is similar? Well, I am asking for any help in a code that I don't have the slightest idea of how to do it.

Thank you very much, in my next post I will have studied more about VBA.

Sub SearchParts()
 Dim arrParts() As Variant
    Range("A7", "D" & Cells(Rows.CountLarge, "D").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("B4: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 4, 1 To 1)
    Do Until FoundCell Is Nothing
        arrPart(1, UBound(arrPart, 2)) = FoundCell.Offset(0, -1)
        arrPart(2, UBound(arrPart, 2)) = FoundCell.Value
        arrPart(3, UBound(arrPart, 2)) = FoundCell.Offset(0, 1)
        arrPart(4, UBound(arrPart, 2)) = FoundCell.Offset(0, 2)
        
        ReDim Preserve arrPart(1 To 4, 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

Well, I did this

 Dim cont As Long
 
    Range("A7", "D" & Cells(Rows.CountLarge, "D").End(xlDown).Row).Clear
    sep = Split(Cells(2, 2), " ")
    
    For cont = LBound(sep) To UBound(sep)
    arrParts = FindParts(CStr(Trim(sep(cont))))
    Range("A7").Resize(UBound(arrParts, 2), UBound(arrParts)) = _
        WorksheetFunction.Transpose(arrParts)
    Next
    
End Sub

But the result is being rewritten. Any suggestions?

This line of decides the type of match you are looking for

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

Set FoundCell = rngParts.Find(What:=PartNumber, After:=LastCell, LookAt:=xlWhole) 'exact match

Second question is already working.

Thank you AB33

First question solved:

 Dim i As Integer

    Range("A7", "D" & Cells(Rows.CountLarge, "D").End(xlDown).Row).Clear
    sep = Split(Cells(2, 2), " ")
    
    i = 1
    
    For cont = LBound(sep) To UBound(sep)
    arrParts = FindParts(CStr(Trim(sep(cont))))
    
    If IsEmpty(Cells(6 + i, 1)) Then
        Cells(6 + i, 1).Resize(UBound(arrParts, 2), UBound(arrParts)) = _
        WorksheetFunction.Transpose(arrParts)
    Else
        Do Until IsEmpty(Cells(6 + i, 1))
            i = i + 1
        Loop
        
        Cells(6 + i, 1).Resize(UBound(arrParts, 2), UBound(arrParts)) = _
        WorksheetFunction.Transpose(arrParts)
        
    End If
        
    Next
    
End Sub