A more accurate and more efficient fuzzy searching algorithm

I have been researching fuzzy match / search algorithms across the internet. I have tried a couple of solutions.

The only that gave somewhat accurate results was from Mr. Excel (http://www.mrexcel.com/pc07.shtml). The problem with this method is the order or relative position of characters in the words and the order of the words themselves had no effect on the results.

I would like to get better results based on the relative word position as well as the order of the letters per word.

Function FuzzyMatchByWord(ByVal lsPhrase1 As String, ByVal lsPhrase2 As String, Optional lbStripVowels As Boolean = False, Optional lbDiscardExtra As Boolean = False) As Double

'' Compare two phrases and return a similarity value (between 0 and 100).
'' Arguments:
'' 1. Phrase1        String; any text string
' 2. Phrase2        String; any text string
' 3. StripVowels    Optional to strip all vowels from the phrases
' 4. DiscardExtra   Optional to discard any unmatched words
''local variables
Dim lsWord1() As String
Dim lsWord2() As String
Dim ldMatch() As Double
Dim ldCur As Double
Dim ldMax As Double
Dim liCnt1 As Integer
Dim liCnt2 As Integer
Dim liCnt3 As Integer
Dim lbMatched() As Boolean
Dim lsNew As String
Dim lsChr As String
Dim lsKeep As String

'set default value as failure
FuzzyMatchByWord = 0

'create list of characters to keep
lsKeep = "BCDFGHJKLMNPQRSTVWXYZ0123456789 "
If Not lbStripVowels Then
    lsKeep = lsKeep & "AEIOU"
End If

'clean up phrases by stripping undesired characters
'phrase1
lsPhrase1 = Trim$(UCase$(lsPhrase1))
lsNew = ""
For liCnt1 = 1 To Len(lsPhrase1)
    lsChr = Mid$(lsPhrase1, liCnt1, 1)
    If InStr(lsKeep, lsChr) <> 0 Then
        lsNew = lsNew & lsChr
    End If
Next
lsPhrase1 = lsNew
lsPhrase1 = Replace(lsPhrase1, "", "")
lsWord1 = Split(lsPhrase1, "")
If UBound(lsWord1) = -1 Then
    Exit Function
End If
ReDim ldMatch(UBound(lsWord1))
'phrase2
lsPhrase2 = Trim$(UCase$(lsPhrase2))
lsNew = ""
For liCnt1 = 1 To Len(lsPhrase2)
    lsChr = Mid$(lsPhrase2, liCnt1, 1)
    If InStr(lsKeep, lsChr) <> 0 Then
        lsNew = lsNew & lsChr
    End If
Next
lsPhrase2 = lsNew
lsPhrase2 = Replace(lsPhrase2, "", "")
lsWord2 = Split(lsPhrase2, "")
If UBound(lsWord2) = -1 Then
    Exit Function
End If
ReDim lbMatched(UBound(lsWord2))

'exit if empty
If Trim$(lsPhrase1) = "" Or Trim$(lsPhrase2) = "" Then
    Exit Function
End If

'compare words in each phrase
For liCnt1 = 0 To UBound(lsWord1)
    ldMax = 0
    For liCnt2 = 0 To UBound(lsWord2)
        If Not lbMatched(liCnt2) Then
            ldCur = FuzzyMatch(lsWord1(liCnt1), lsWord2(liCnt2))
            If ldCur > ldMax Then
                liCnt3 = liCnt2
                ldMax = ldCur
            End If
        End If
    Next
    lbMatched(liCnt3) = True
    ldMatch(liCnt1) = ldMax
Next

'discard extra words
ldMax = 0
For liCnt1 = 0 To UBound(ldMatch)
    ldMax = ldMax + ldMatch(liCnt1)
Next
If lbDiscardExtra Then
    liCnt2 = 0
    For liCnt1 = 0 To UBound(lbMatched)
        If lbMatched(liCnt1) Then
            liCnt2 = liCnt2 + 1
        End If
    Next
Else
    liCnt2 = UBound(lsWord2) + 1
End If

'return overall similarity
FuzzyMatchByWord = 100 * (ldMax / liCnt2)


End Function

Function FuzzyMatch(Fstr As String, Sstr As String) As Double

'' Code sourced from: http://www.mrexcel.com/pc07.shtml
' Credited to: Ed Acosta
' Modified: Joe Stanton
'

Dim L, L1, L2, M, SC, T, R As Integer

L = 0
M = 0
SC = 1

L1 = Len(Fstr)
L2 = Len(Sstr)

Do While L < L1
    L = L + 1
    For T = SC To L1
        If Mid$(Sstr, L, 1) = Mid$(Fstr, T, 1) Then
            M = M + 1
            SC = T
            T = L1 + 1
        End If
    Next T
Loop

If L1 = 0 Then
    FuzzyMatch = 0
Else
    FuzzyMatch = M / L1
End If

End Function

I am trying to compare account descriptions from a trial balance to a list of 30,000 past account descriptions and I want to find the 5 top results per account.

To give you an example:

Debug.Print FuzzyMatchByWord("Cash and Cash Equivalents", "Bank and Cash")
Debug.Print FuzzyMatchByWord("Cash and Cash Equivalents", "Cash and Bank")
Debug.Print FuzzyMatchByWord("Cash and Cash Equivalents", "Shack sequential")
Debug.Print FuzzyMatchByWord("Cash and Cash Equivalents", "Sequential shack")

Returns:

75 
75 
37.5 
37.5

I would want the relative placement of a word in a phrase to count more towards the score and I would also prefer the order of the letters have a bigger impact. Sequential shack should not have scored that high compared to Cash and Cash Equivalents.