Matching similar but not exact text strings in Excel VBA projects

Solution 1:

I would place the macro in your PERSONAL section, this way the macro is available in all worksheets. Do this by recording a dummy macro and select to store it in Personal Macro workbook. Now you can manually add new macro's and functions in this personal workbook.

I just tried this one (don't know the original source) and it works fine.

The formula looks like this: =PERSONAL.XLSB!FuzzyFind(A1,B$1:B$20)

The code is here:

Function FuzzyFind(lookup_value As String, tbl_array As Range) As String
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
For Each cell In tbl_array
  str = cell
  For i = 1 To Len(lookup_value)
    If InStr(cell, Mid(lookup_value, i, 1)) > 0 Then
      a = a + 1
      cell = Mid(cell, 1, InStr(cell, Mid(lookup_value, i, 1)) - 1) & Mid(cell, InStr(cell, Mid(lookup_value, i, 1)) + 1, 9999)
    End If
  Next i
  a = a - Len(cell)
  If a > b Then
    b = a
    Value = str
  End If
  a = 0
Next cell
FuzzyFind = Value
End Function

Solution 2:

You can Google Excel UDF Fuzzy lookup or Levensthein distance. There are some UDF's floating around and Microsoft does have a Fuzzy lookup/match add-on as well (when I used it, it was crash prone and not intuitive).

Solution 3:

I used Robert solution and it works fine for me. I am posting whole solution for people who are new for excel but knows coding:

Though this thread is old but I took some code from another threads and tried and looks like solution is giving approx match. Here I am trying to match one column of sheet1 with one column of sheet2:

1. add command button in excel
2. put following code and click/run button and function gives you result in selected column

 Private Sub CommandButton21_Click()
     Dim ws As Worksheet
     Dim LRow As Long, i As Long, lval As String


   '~~> Change this to the relevant worsheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

With ws
    '~~> Find Last Row in Col G which has data
    LRow = .Range("D" & .Rows.Count).End(xlUp).Row

    If LRow = 1 Then
        MsgBox "No data in column D"
    Else
        For i = 2 To LRow


             lval = "D"
            .Range("G" & i).Value = FuzzyFind(lval & i, .Range("PWC"))
        Next i
    End If
    End With

    End Sub


    Function FuzzyFind(lookup_value As String, tbl_array As Range) As String
    Dim i As Integer, str As String, Value As String
    Dim a As Integer, b As Integer, cell As Variant

    For Each cell In tbl_array
     str = cell
     For i = 1 To Len(lookup_value)
      If InStr(cell, Mid(lookup_value, i, 1)) > 0 Then
     a = a + 1
     cell = Mid(cell, 1, InStr(cell, Mid(lookup_value, i, 1)) - 1) & Mid   (cell, InStr(cell, Mid(lookup_value, i, 1)) + 1, 9999)
    End If
     Next i
     a = a - Len(cell)
     If a > b Then
       b = a
       Value = str
    End If
       a = 0
    Next cell
      If Value <> "" Then
         FuzzyFind = Value
      Else
         FuzzyFind = "None"
      End If
End Function