VLOOKUP Closest Match Not Close Enough

Hi,

Can someone please tell me how i use the below code.

I am new to this, so I have no idea

Thanks

Panic

Originally Posted by bestresearch

Vlookup does a poor job with non-exact text matches.

Prior posts do a great job of finding exact text matches, but I decided to write one with closest text match.

Note, the optional range_lookup paramater does not do anything. Perhaps will implement that in the future to require exact match.

Works on my machine, but usual caveat of no guarantees...

Option Explicit

Function ColumnLetter(ColumnNumber As Integer) As String
  If ColumnNumber > 26 Then

    ' 1st character:  Subtract 1 to map the characters to 0-25,
    '                 but you don't have to remap back to 1-26
    '                 after the 'Int' operation since columns
    '                 1-26 have no prefix letter

    ' 2nd character:  Subtract 1 to map the characters to 0-25,
    '                 but then must remap back to 1-26 after
    '                 the 'Mod' operation by adding 1 back in
    '                 (included in the '65')

    ColumnLetter = Chr(Int((ColumnNumber - 1) / 26) + 64) & _
                   Chr(((ColumnNumber - 1) Mod 26) + 65)
  Else
    ' Columns A-Z
    ColumnLetter = Chr(ColumnNumber + 64)
  End If
End Function

Function ReverseText(text) As String
Dim TextLen As Integer
Dim i As Integer
TextLen = Len(text)
For i = TextLen To 1 Step -1
  ReverseText = ReverseText & Mid(text, i, 1)
Next i
End Function

Function TVLOOKUP(lookup_value As String, table_array As Range, col_index_num As Integer, Optional range_lookup As Boolean) As Variant

Dim cell As Range
Dim match_column As Range ' this is the first column in table_array
Dim BestMatch As Variant
Dim lookup_position As Integer
Dim total_distance As Integer
Dim right_char_distance, left_char_distance, char_distance As Integer
Dim match_column_string As String
Dim lookup_char, rev_cell_substr, cell_substr As String
Dim minimum_distance As Integer

' Function is case insenstive, so convert lookup value
lookup_value = LCase(lookup_value)

' Set match_column as first column in table_array
match_column_string = ColumnLetter(table_array.Cells(1, 1).Column) _
            & CStr(table_array.Cells(1, 1).Row) _
            & ":" _
            & ColumnLetter(table_array.Cells(1, 1).Column) _
            & CStr(table_array.Cells(1, 1).Row + table_array.Rows.Count - 1)
Set match_column = ActiveSheet.Range(match_column_string)

' set minimum_distance very large
minimum_distance = 10000

For Each cell In match_column
  ' idea here is to do a character by character comparison
  ' that is more sopisticated than a simple exact match
  ' instead determining how far matching character is away
  ' and ultimately choosing match with shortest total distance
  lookup_position = 1
  total_distance = 0
  While (lookup_position <= Len(LCase(cell.Value))) _
  And (lookup_position <= Len(lookup_value))
  
    ' first figure out right character distance
    lookup_char = Mid(lookup_value, lookup_position, 1)
    cell_substr = Mid(LCase(cell.Value), lookup_position)
    right_char_distance = InStr(1, cell_substr, lookup_char, vbTextCompare)
    If right_char_distance = 0 Then
      ' character was not found so increase to be "beyond string"
      right_char_distance = Application.WorksheetFunction.Max(Len(LCase(cell.Value)), Len(lookup_value)) + 1
    End If
    
    ' now figure out left char distance
    rev_cell_substr = ReverseText(Left(LCase(cell.Value), lookup_position))
    left_char_distance = InStr(1, rev_cell_substr, lookup_char, vbTextCompare)
    If left_char_distance = 0 Then
      ' character was not found so increase to be "beyond string"
      left_char_distance = Application.WorksheetFunction.Max(Len(LCase(cell.Value)), Len(lookup_value)) + 1
    End If
    
    char_distance = Application.WorksheetFunction.Min(left_char_distance, right_char_distance)
    
    total_distance = total_distance + char_distance - 1
    lookup_position = lookup_position + 1
  Wend
  If Len(lookup_value) <> Len(LCase(cell.Value)) Then
    total_distance = total_distance + _
        (Abs(Len(lookup_value) - Len(LCase(cell.Value))) _
        * Application.WorksheetFunction.Max(Len(LCase(cell.Value)), Len(lookup_value)))
  End If
  
  If total_distance <= minimum_distance Then
    minimum_distance = total_distance
    BestMatch = table_array.Cells(cell.Row - table_array.Cells(1, 1).Row + 1, _
        col_index_num).Value
  End If
Next cell

TVLOOKUP = BestMatch
End Function