Edit VBA Userform code to run if only 1 entry that matches criteria

Hi there

I have the following code:

Private Sub ComboBox1_Change()

End Sub

Private Sub ListBox1_Click()

End Sub

Private Sub UserForm_Click()

End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Selection.Value = ListBox1.Value
    Unload Me
End Sub

Private Sub UserForm_Initialize()
Dim rRng As Range, r As Range, rSortCr As String

Set rRng = Sheet2.Range("a2:a5567")
rSortCr = UCase(ActiveCell.Value)

For Each r In rRng
    If InStr(UCase(r), rSortCr) Then Me.ListBox1.AddItem r.Value
Next r

End Sub

Can anyone help me to edit the code so that if there is only one entry that meets the criteria, it will be just put into the selected cell when I run the macro?

Thank you.

Sorry I'm fairly new to VBA - hence the username..

At the moment, what it does is searches in ("a2:a5567") and returns any of the entries that match the criteria. The criteria is what I've already typed into the cell. So I type something in and then run the macro and it is effectively a drop down but it comes up in a userform instead.

This make sense or no?

No there sometimes will be more than 1 match - normally in fact...

So I'm basically searching in the range for the text in cell and then returning the results in a userform..as far as i understand

Yep Ok I'll do that in just a sec. Basically what it is is IF there is only 1 match I would like it to automatically chose that one for me.

Sample1.xlsm Here it is

Thanks..what do you mean by the loop?

Thanks that works - how do I unload the userform after it's chosen the word for me?

Ok so I can't get it to do that for me?

Excellent, perfect. Thanks very much for your time. Have some rep