Match partial text string (90%) two column in two different sheet - excel

Question

I'm trying to match (90%) partial text string from a sheet column to another sheet column and bring end result to the master sheet column.
I found a VBA solution but I have some problems with that.
1) it's matching exact text
2) finding a problem to match two different sheet columns.
Please help me to sort this out.
Sub lookup()
Dim TotalRows As Long
Dim rng As Range
Dim i As Long
'Copy lookup values from sheet1 to sheet3
Sheets("BANK STATEMENT ENTRY").Select
TotalRows = ActiveSheet.UsedRange.Rows.Count
Range("F3:F" & TotalRows).Copy Destination:=Sheets("TEST").Range("A1")
'Go to the destination sheet
Sheets("TEST").Select
For i = 1 To TotalRows
'Search for the value on sheet2
Set rng = Sheets("INFO").UsedRange.Find(Cells(i, 1).Value)
'If it is found put its value on the destination sheet
If Not rng Is Nothing Then
Cells(i, 2).Value = rng.Value
End If
Next
End Sub

Answer 1

I have done a text mining project and I know you cannot use that approach, you have to break the strings into substrings and then analyze them. It will be a whole project, but you are lucky since I did it for you.
Let's simplify the problem and say that you have two ranges of strings and you want to find every similar strings between two groups. Also, you want to have a tolerance to minimize the matching pairs.
Assume ABCDE and 12BCD00. They have B, C, D, BC, CD and BCD in common. So the longest common substring is BCD which is 3 characters: 3/length of ABCDE(5) will be 60% similarity with the first string and 3/7=43% similarity. So if you can get a list of all those common substrings among all the strings in two ranges you can come up with a better list to filter and get what you want.
I wrote a bunch of functions. To use it easily, just copy and paste both groups of strings in one sheet and generate the final report on the same sheet too to understand how it works.
Function FuzzyFind, finds all of the common substrings and gives you 1st string from Group1/range1, 2nd string from group2/range2, common substring and percentages of similiarity for both strings. The good thing is you can tell the function how small you want your substrings e.g. in the previous example, if you say iMinCommonSubLength=3, it will only give you BCD, if you say iMinCommonSubLength=2 it will give you BC, CD and BCD and so on.
Use function Main. I also included a Test sub.
Functions:
Sub TestIt()
Call Main(ActiveSheet.Range("A1:A10"), ActiveSheet.Range("B1:B10"), 4, ActiveSheet.Range("D1"))
End Sub
Sub Main(rng1 As Range, rng2 As Range, iMinCommonSubLength As Integer, Optional rngReportUpperLeftCell As Range)
Dim arr() As Variant
Dim rngReport As Range
If rngReport Is Nothing Then Set rngReport = ActiveSheet.Range("A1")
arr = FuzzyFind(rng1, rng2, iMinCommonSubLength)
Set rngReport = rngReportUpperLeftCell.Resize(UBound(arr, 1), UBound(arr, 2))
rngReport.Value = arr
rngReport.Columns(1).NumberFormat = "#"
rngReport.Columns(2).NumberFormat = "#"
rngReport.Columns(3).NumberFormat = "#"
rngReport.Columns(4).NumberFormat = "0%"
rngReport.Columns(5).NumberFormat = "0%"
End Sub
Function GetCharacters(str As String) As Variant
Dim arr() As String
ReDim arr(Len(str) - 1)
For i = 1 To Len(str)
arr(i - 1) = Mid$(UCase(str), i, 1)
Next
GetCharacters = arr
End Function
Function GetIterations(iStringLength As Integer, iSubStringLength As Integer) As Integer
If iStringLength >= iSubStringLength Then
GetIterations = iStringLength - iSubStringLength + 1
Else
GetIterations = 0
End If
End Function
Function GetSubtrings(str As String, iSubLength As Integer) As Variant
Dim i As Integer
Dim count As Integer
Dim arr() As Variant
count = GetIterations(Len(str), iSubLength)
ReDim arr(1 To count)
For i = 1 To count
arr(i) = Mid(str, i, iSubLength)
Next i
GetSubtrings = arr()
End Function
Function GetLongestCommonSubStrings(str1 As String, str2 As String, iMinCommonSubLeng As Integer)
Dim i As Integer
Dim iLongestPossible As Integer
Dim iShortest As Integer
Dim arrSubs() As Variant
Dim arr1() As Variant
Dim arr2() As Variant
ReDim arrSubs(1 To 1)
'Longest possible common substring length is the smaller string's length
iLongestPossible = IIf(Len(str1) > Len(str2), Len(str2), Len(str1))
If iLongestPossible < iMinCommonSubLeng Then
'MsgBox "Minimum common substring length is larger than the shortest string." & _
' " You have to choose a smaller common length", , "Error"
Else
'We will try to find the first match of common substrings of two given strings, exit after the first match
For i = iLongestPossible To iMinCommonSubLeng Step -1
arr1 = GetSubtrings(str1, i)
arr2 = GetSubtrings(str2, i)
ReDim arrSubs(1 To 1)
arrSubs = GetCommonElement(arr1, arr2)
If arrSubs(1) <> "" Then Exit For 'if you want JUST THE LONGEST MATCH, comment out this line
Next i
End If
GetLongestCommonSubStrings = arrSubs
End Function
Function GetCommonElement(arr1() As Variant, arr2() As Variant) As Variant
Dim i As Integer
Dim j As Integer
Dim count As Integer
Dim arr() As Variant
count = 1
ReDim arr(1 To count)
For i = 1 To UBound(arr1)
For j = 1 To UBound(arr2)
If arr1(i) = arr2(j) Then
ReDim Preserve arr(1 To count)
arr(count) = arr1(i)
count = count + 1
End If
Next j
Next i
GetCommonElement = arr
End Function
Function FuzzyFind(rng1 As Range, rng2 As Range, iMinCommonSubLength As Integer) As Variant
Dim count As Integer
Dim i As Integer
Dim arrSubs As Variant
Dim str1 As String
Dim str2 As String
Dim cell1 As Range
Dim cell2 As Range
Dim rngReport As Range
Dim arr() As Variant 'array of all cells that are partially matching, str1, str2, common string, percentage
count = 1
ReDim arr(1 To 5, 1 To count)
For Each cell1 In rng1
str1 = UCase(CStr(cell1.Value))
If str1 <> "" Then
For Each cell2 In rng2
str2 = UCase(CStr(cell2.Value))
If str2 <> "" Then
ReDim arrSubs(1 To 1)
arrSubs = GetLongestCommonSubStrings(str1, str2, iMinCommonSubLength)
If arrSubs(1) <> "" Then
For i = 1 To UBound(arrSubs)
arr(1, count) = cell1.Value
arr(2, count) = cell2.Value
arr(3, count) = arrSubs(i)
arr(4, count) = Len(arrSubs(i)) / Len(str1)
arr(5, count) = Len(arrSubs(i)) / Len(str2)
count = count + 1
ReDim Preserve arr(1 To 5, 1 To count)
Next i
End If
End If
Next cell2
End If
Next cell1
FuzzyFind = TransposeArray(arr)
End Function
Function TransposeArray(arr As Variant) As Variant
Dim arrTemp() As Variant
ReDim arrTemp(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1))
For a = LBound(arr, 2) To UBound(arr, 2)
For b = LBound(arr, 1) To UBound(arr, 1)
arrTemp(a, b) = arr(b, a)
Next b
Next a
TransposeArray = arrTemp
End Function
Don't forget to clear the sheet before generating new reports. Insert a table and use its autofilter to easily filter your stuff.
last but not least, don't forget to click on the check mark to announce this as the answer to your question.