Compare addresses and show percentage of similarities

[fokeiro]

hi guys. im tryign to compare addresses on column A vs column B and needs to show what is the percentage of similarity. this is my code so far, one sheet called CM, sheet2 called ABC, sheet 3 called MATCH copy both to here and show percentage. my code is below but im not sure why something completely different show a big % of similarity. see attached image and code. ty guys.

[TABLE="width: 344"]
<tbody>[TR]
[TD][TABLE="width: 344"]
<tbody>[TR]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
[TABLE="width: 344"]
<tbody>[TR]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
</tbody>[/TABLE]
<strike></strike>

 Application.ScreenUpdating = False
LR = Sheets("CM").Cells(Rows.Count, 1).End(xlUp).Row
With Sheets("MATCH")
.Range("B1:B" & LR).Value = Sheets("CM").Range("B1:B" & LR).Value
.Range("C1:C" & LR).Value = Sheets("ABC").Range("B1:B" & LR).Value
.Range("A1:A" & LR).Value = Sheets("CM").Range("A1:A" & LR).Value
For r = 2 To LR
If Trim(.Cells(r, "A").Value) = Trim(.Cells(r, "B").Value) Then
.Cells(r, "C").Value = 1
GoTo Done
End If
Str1 = Trim(.Cells(r, "B").Value)
Str2 = Trim(.Cells(r, "C").Value)
Len1 = Len(Str1)
Len2 = Len(Str2)
Same = 0
For c = 1 To Len2
If InStr(1, Str1, Mid(Str2, c, 1), 1) Then
Same = Same + 1
Str1 = Replace(Str1, Mid(Str2, c, 1), "*", 1, 1)
End If
Next c
.Cells(r, "D").Value = Same / Len1
Done:
Next r
End With
Application.ScreenUpdating = True

 

[fokeiro]

for some reason im getting a error 6 - overflow on this line

.Cells(r, "E").Value = (maxlen - LevDist(str1, str2)) / maxlen

but if I comment it out seems still works without the error

 

[fokeiro]

shg tried the ratio but while with lev dist i get 85% in this example with ratio i get 23% , only extra is # 436 on column B string

[TABLE="width: 792"]
<colgroup><col><col></colgroup><tbody>[TR]
[TD]101 E ROMANA ST PENSACOLA FL 32502[/TD]
[TD]101 E ROMANA ST # 436 PENSACOLA FL 32502[/TD]
[/TR]
</tbody>[/TABLE]

 

[shg]

Yes it does.

OTOH, 1871 NW SOUTH RIVER DR UNIT 17 MIAMI FL 33125 and 108-136 MARTIN LUTHER KING JR BLVD APT 1317 NEWARK NJ 07104 have an edit distance ratio of 34%, which seems like a awful lot of similarity, vs a qTR of 0.33%.

Reckon it depends on which best serves your purpose.

 

[fokeiro]

thanks for the help guys

 

[fokeiro]

I just keep getting a overflow on this line . Seems the code wants to do 9 rows if there is only let say 3 it throws in a overflow I guess trying to check with null cells

Sub Test1()
Dim str1 As String, str2 As String
    Application.ScreenUpdating = False
    LR = Sheets("CM").Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("MATCH")
        .Range("B1:B" & LR).Value = Sheets("CM").Range("B1:B" & LR).Value
        .Range("C1:C" & LR).Value = Sheets("ABC").Range("B1:B" & LR).Value
        .Range("A1:A" & LR).Value = Sheets("CM").Range("A1:A" & LR).Value
        LR = 9
        For r = 2 To LR
            If Trim(.Cells(r, "B").Value) = Trim(.Cells(r, "C").Value) Then
                .Cells(r, "D").Value = 1
                GoTo Done
            End If
            str1 = Trim(.Cells(r, "B").Value)
            str2 = Trim(.Cells(r, "C").Value)
            Len1 = Len(str1)
            Len2 = Len(str2)
            Same = 0
            For c = 1 To Len2
                If InStr(1, str1, Mid(str2, c, 1), 1) Then
                    Same = Same + 1
                    str1 = Replace(str1, Mid(str2, c, 1), "*", 1, 1)
                End If
            Next c
            .Cells(r, "D").Value = Same / Len1
Done:
            str1 = LCase(.Cells(r, "B"))
            str2 = LCase(.Cells(r, "C"))
            maxlen = IIf(Len(str1) > Len(str2), Len(str1), Len(str2))
  [COLOR=#ff0000]         .Cells(r, "E").Value = (maxlen - LevDist(str1, str2)) / maxlen  <----overflow[/COLOR]
        Next r
    End With
    Application.ScreenUpdating = True
End Sub

 

[Eric W]

I wondered if I should put a check in there. You're getting the error because both str1 and str2 are empty. So the maxlen is 0, so you're dividing by zero. You can just put something like this:

            str1 = LCase(.Cells(r, "B"))
            str2 = LCase(.Cells(r, "C"))
            maxlen = IIf(Len(str1) > Len(str2), Len(str1), Len(str2))
            If maxlen = 0 Then
              .Cells(r, "E").Value = "No addresses"
           Else
             .Cells(r, "E").Value = (maxlen - LevDist(str1, str2)) / maxlen
           End If

 

[fokeiro]

eric you the man, that did the trick, figure it was diving by 0 and saw LR defines how many rows it shold work on, so now with more rows on LR, still no overflow, perfect thank you !!!

 

[Eric W]

You're welcome!