Help with my VBA. Using input box to find name. Need to find partials and deal with duplicates

[ILMWT]

Here is the VBA
<code style="font-family: monospace, monospace; margin: 0px 2px; border: 0px; border-radius: 2px; word-break: normal; display: block; font-size: 1em; line-height: 1.42857142857143em; padding: 0px !important; background-color: transparent;">Sub FindName()

Dim FindString As String

Dim Rng As Range

FindString = InputBox("Enter Persons Name")

If Trim(FindString) <> "" Then

With Sheets("Tracking").Range("D:D")

Set Rng = .Find(What:=FindString, _

After:=.Cells(.Cells.Count), _

LookIn:=xlValues, _

LookAt:=xlWhole, _

SearchOrder:=xlByRows, _

SearchDirection:=xlNext, _

MatchCase:=False)

If Not Rng Is Nothing Then

Application.Goto Rng, True

Else

MsgBox "Nothing found"

End If

End With

End If

End Sub
</code>What I need it to do is find partials. If I am searching for Doe, Jane I would like to be able to type in "Doe" or "Jane" to find the name. Also, if there are more than 1 Janes, how do I deal with this?
Thank you. Will credit with verified solutions.

 

[RudiS]

This code will find partial matches and duplicate entries...

Sub FindName()
Dim rF As Range, rD As Range
Dim sFAddr As String
Dim FindString As String


    FindString = InputBox("Enter Persons Name")
    Application.ScreenUpdating = False
    With Sheets("Tracking").Range("D:D")
        Set rF = .Find(What:=FindString, Lookat:=xlPart, SearchOrder:=xlByRows, _
                       SearchDirection:=xlNext, MatchCase:=False)
        If Not rF Is Nothing Then
            Set rD = rF
            sFAddr = rF.Address
            Set rF = .FindNext(after:=rF)
            Do Until rF.Address = sFAddr
                Set rD = Application.Union(rD, rF)
                Set rF = .FindNext(after:=rF)
            Loop
        End If
    End With
    If Not rD Is Nothing Then rD.Select
    Application.ScreenUpdating = True
End Sub

 

[ILMWT]

This is perfect. Thank you!

 

[RudiS]

Excellent