Comparing Similiar DataSets and Calling a Function From a Loop Within a Loop

Hello Community

I posted a similar message which I am grateful that many of you helped out

I was wondering if someone could help me one step further.

I found the following code:-

http://superuser.com/questions/43738...rings-in-excel

Public Function Similarity(ByVal String1 As String, _
ByVal String2 As String, _
Optional ByRef RetMatch As String, _
Optional min_match = 1) As Single
Dim b1() As Byte, b2() As Byte
Dim lngLen1 As Long, lngLen2 As Long
Dim lngResult As Long

If UCase(String1) = UCase(String2) Then
Similarity = 1
Else:
lngLen1 = Len(String1)
lngLen2 = Len(String2)
If (lngLen1 = 0) Or (lngLen2 = 0) Then
Similarity = 0
Else:
b1() = StrConv(UCase(String1), vbFromUnicode)
b2() = StrConv(UCase(String2), vbFromUnicode)
lngResult = Similarity_sub(0, lngLen1 - 1, _
0, lngLen2 - 1, _
b1, b2, _
String1, _
RetMatch, _
min_match)
Erase b1
Erase b2
If lngLen1 >= lngLen2 Then
Similarity = lngResult / lngLen1
Else
Similarity = lngResult / lngLen2
End If
End If
End If

End Function

Private Function Similarity_sub(ByVal start1 As Long, ByVal end1 As Long, _
ByVal start2 As Long, ByVal end2 As Long, _
ByRef b1() As Byte, ByRef b2() As Byte, _
ByVal FirstString As String, _
ByRef RetMatch As String, _
ByVal min_match As Long, _
Optional recur_level As Integer = 0) As Long
'* CALLED BY: Similarity *(RECURSIVE)

Dim lngCurr1 As Long, lngCurr2 As Long
Dim lngMatchAt1 As Long, lngMatchAt2 As Long
Dim I As Long
Dim lngLongestMatch As Long, lngLocalLongestMatch As Long
Dim strRetMatch1 As String, strRetMatch2 As String

If (start1 > end1) Or (start1 < 0) Or (end1 - start1 + 1 < min_match) _
Or (start2 > end2) Or (start2 < 0) Or (end2 - start2 + 1 < min_match) Then
Exit Function '(exit if start/end is out of string, or length is too short)
End If

For lngCurr1 = start1 To end1
For lngCurr2 = start2 To end2
I = 0
Do Until b1(lngCurr1 + I) <> b2(lngCurr2 + I)
I = I + 1
If I > lngLongestMatch Then
lngMatchAt1 = lngCurr1
lngMatchAt2 = lngCurr2
lngLongestMatch = I
End If
If (lngCurr1 + I) > end1 Or (lngCurr2 + I) > end2 Then Exit Do
Loop
Next lngCurr2
Next lngCurr1

If lngLongestMatch < min_match Then Exit Function

lngLocalLongestMatch = lngLongestMatch
RetMatch = ""

lngLongestMatch = lngLongestMatch _
+ Similarity_sub(start1, lngMatchAt1 - 1, _
start2, lngMatchAt2 - 1, _
b1, b2, _
FirstString, _
strRetMatch1, _
min_match, _
recur_level + 1)
If strRetMatch1 <> "" Then
RetMatch = RetMatch & strRetMatch1 & "*"
Else
RetMatch = RetMatch & IIf(recur_level = 0 _
And lngLocalLongestMatch > 0 _
And (lngMatchAt1 > 1 Or lngMatchAt2 > 1) _
, "*", "")
End If


RetMatch = RetMatch & Mid$(FirstString, lngMatchAt1 + 1, lngLocalLongestMatch)


lngLongestMatch = lngLongestMatch _
+ Similarity_sub(lngMatchAt1 + lngLocalLongestMatch, end1, _
lngMatchAt2 + lngLocalLongestMatch, end2, _
b1, b2, _
FirstString, _
strRetMatch2, _
min_match, _
recur_level + 1)

If strRetMatch2 <> "" Then
RetMatch = RetMatch & "*" & strRetMatch2
Else
RetMatch = RetMatch & IIf(recur_level = 0 _
And lngLocalLongestMatch > 0 _
And ((lngMatchAt1 + lngLocalLongestMatch < end1) _
Or (lngMatchAt2 + lngLocalLongestMatch < end2)) _
, "*", "")
End If

Similarity_sub = lngLongestMatch

End Function

Essentially it is a function that takes in two strings and compares them. Based on how close the two strings are, the function outputs a value between 0 and 1, where 0 being no comparison between the two strings and 1 being the two strings are equal.


With the help of a user from this forum, a macro was written so that the function would be called to compare two columns of data and if a match of 0.8 or greater was found then the row from the 1st column would be cut and pasted next to the corresponding row of the second column. The code for this was:-

Sub Test()
Dim arr1(), arr2(), i As Long, j As Long, str1 As String

Sheets("Sheet1").Select
arr1 = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value
arr2 = Range("C2:C" & Cells(Rows.Count, "C").End(xlUp).Row).Value

For i = 1 To UBound(arr2, 1)
If Len(arr2(i, 1)) Then
str1 = arr2(i, 1)
arr2(i, 1) = ""
For j = 1 To UBound(arr1, 1)
If Len(arr1(j, 1)) Then
If Similarity(str1, arr1(j, 1)) > 0.8 Then
arr2(i, 1) = arr1(j, 1)
arr1(j, 1) = ""
Exit For
End If
End If
Next j
End If
Next I

Range("A2").Resize(UBound(arr1, 1), 1).Value = arr1
Columns("D").ClearContents
Range("D2").Resize(UBound(arr2, 1), 1).Value = arr2
End Sub

I wanted to amend the code do the same thing but in a slightly different way.

I have Database 1 which is always located between columns A and P.

I have Database 2 is located between Columns R and AG.

I wanted to amend the code so that each row in Database 2 is compared with each row in Database 1 and if a match is found than the row in Database 1 is cut and pasted next to the corresponding row in Database 2.

But this time I wanted to find a match based on 3 tests of the similarity function:-

The first test is that the first cell in Database 2 (R3) is compared with every row in column A of database 1 and the match must be greater than 0.9.

The second test is that the second cell in Database 2 (S3) is compared with every row in column B of database 1 and the match must be greater than 0.7.

The third test is that the third cell in Database 2 (T3) is compared with every row in column C of database 1 and the match must be greater than 0.8.

The macro should essentially take the first 3 cells of each row in database 2 and compares it with the first three cells of every row in database 1, a match is only found if the similarity function returns 0.9, 0.7, 0.8 or greater for each cell comparison.

If a match is found then the entire row of database 1 (columns A - P) is cut and pasted next to the corresponding row in Database 2 (Column AH).

Can you help at all?

I have attached the excel 2003 spread set which contains the two databases and included the similarity function.

Thanks