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.
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
Bookmarks