Public Function At_GetClosestWord(ByRef What As Range, ByRef Where As Range, Optional ByVal NumItem As Long = 1) As Variant

Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H1

Dim objConnection As Object
Dim objRecordset As Object
Dim arr As Variant
Dim strConnection As String
Dim strSQL As String
Dim strText As String
Dim strTextRang As String
Dim WhatLen As Integer
Dim i As Integer

WhatLen = Len(What)
If WhatLen < 3 Then
    Return
End If
Set objConnection = CreateObject("ADODB.Connection")
Set objRecordset = CreateObject("ADODB.Recordset")
strConnection = IIf(Val(Application.Version) < 12, "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 8.0;HDR=NO;IMEX=1';", "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 12.0;HDR=NO;IMEX=1';")
objConnection.Open strConnection
strText = "0"
For i = 1 To WhatLen - 2
    strText = strText & "+iif(instr(f1,'" & Mid(What, i, 3) & "')>0,1,0)"
Next
strTextRang = "iif(mid(f1," & (WhatLen + 1) & ",3)=''," & WhatLen & ", len(f1))"
strSQL = "select top 20 100*(" + strText + ")/(" + strTextRang + " - 2) as rang,f1 from [" + Where.Worksheet.Name + "$" + Where.Address(False, False) + "] order by 1 desc"
objRecordset.Open strSQL, objConnection, adOpenStatic, adLockOptimistic, adCmdText
arr = objRecordset.getRows
At_GetClosestWord = arr(1, NumItem - 1)

End Function