Compare addresses and show percentage of similarities

fokeiro · Mar 11, 2019

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>

Code:

 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

Eric W · Mar 12, 2019

Your macro to calculate similarity isn't especially useful. It calculates the number of letters that are the same in both addresses, but if the letters are in different places, it'll give you a high similarity rating, even though the addresses look quite different. Instead, you might want to use something called the Levenshtein Distance, which basically tells you how many changes (adds, changes, deletes) you need to make to one string to make it into the other string. Zero changes means they are the same, a high number means they are very different. You can convert this into a percentage by dividing the number of changes by the length of the longest string.

Here's what I get when I try that:

Excel 2012

	B	C
CM ADDRESS	ABC ADDRESS	PERCENTAGE MATCH
2380 BAYSIDE ST NAPLES FL 34112	2380 BAYSIDE ST NAPLES FL 34112
3800 GRAND LN APT 206 TITUSVILLE FL 32780	3800 GRAND LN APT 206 TITUSVILLE FL 32780
505 FERDINAND AVE DELTONA FL 32780	5478 South St Sodus NY 14551-9542
10612 108TH ST LARGO FL 33778
1449 SUGARBERRY LN SAINT CLOUD FL 34772	3938 CEDAR HAMMOCK TRL SAINT CLOUD FL 34772
5004 BARNSTEAD DR RIVERVIEW FL 33578
1871 NW SOUTH RIVER DR UNIT 17 MIAMI FL 33125	108-136 MARTIN LUTHER KING JR BLVD APT 1317 NEWARK NJ 07104
581 OVAL CT APOPKA FL 32703

<colgroup><col style="width: 25pxpx"><col><col><col><col></colgroup><thead>
</thead><tbody>
[TD="align: center"]1[/TD]

[TD="align: right"][/TD]

[TD="align: center"]2[/TD]

[TD="align: right"]100.00%[/TD]
[TD="align: right"]100.00%[/TD]

[TD="align: center"]3[/TD]

[TD="align: right"]100.00%[/TD]
[TD="align: right"]100.00%[/TD]

[TD="align: center"]4[/TD]

[TD="align: right"]47.06%[/TD]
[TD="align: right"]8.82%[/TD]

[TD="align: center"]5[/TD]

[TD="align: right"][/TD]
[TD="align: right"]0.00%[/TD]
[TD="align: right"]0.00%[/TD]

[TD="align: center"]6[/TD]

[TD="align: right"]74.36%[/TD]
[TD="align: right"]58.14%[/TD]

[TD="align: center"]7[/TD]

[TD="align: right"][/TD]
[TD="align: right"]0.00%[/TD]
[TD="align: right"]0.00%[/TD]

[TD="align: center"]8[/TD]

[TD="align: right"]80.00%[/TD]
[TD="align: right"]33.90%[/TD]

[TD="align: center"]9[/TD]

[TD="align: right"][/TD]
[TD="align: right"]0.00%[/TD]
[TD="align: right"]0.00%[/TD]

</tbody>

MATCH

Your values in D, mine in E.

Here's the code I used:

Rich (BB code):

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))
            .Cells(r, "E").Value = (maxlen - LevDist(str1, str2)) / maxlen
        Next r
    End With
    Application.ScreenUpdating = True
End Sub

Public Function LevDist(str1 As String, str2 As String)
Dim d() As Long, m As Long, n As Long, i As Long, j As Long, Cost As Long

    m = Len(str1)
    n = Len(str2)
    ReDim d(0 To m, 0 To n)
    
    For i = 1 To m
        d(i, 0) = i
    Next i
    
    For j = 1 To n
        d(0, j) = j
    Next j
    
    For j = 1 To n
        For i = 1 To m
            Cost = IIf(Mid(str1, i, 1) = Mid(str2, j, 1), 0, 1)
            d(i, j) = WorksheetFunction.Min(d(i - 1, j) + 1, d(i, j - 1) + 1, d(i - 1, j - 1) + Cost)
        Next i
    Next j
    
    LevDist = d(m, n)
    
End Function

Fluff · Mar 12, 2019

Cross posted https://www.excelforum.com/excel-pr...resses-and-show-percentage-of-similarity.html

While we do not prohibit Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules).
This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered.

fokeiro · Mar 12, 2019

Fluff said:
Cross posted https://www.excelforum.com/excel-pr...resses-and-show-percentage-of-similarity.html

While we do not prohibit Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules).
This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered.

got it thanks for pointing it out.

fokeiro · Mar 12, 2019

Hi Eric, I tried ur code without modifications of course but weirdly using same values as you I get different result. see attach shot. why would it be the 0% wouldn't turn 0% on column E ? percentage ?

fokeiro · Mar 12, 2019

update: disregard, seems on the blank lines there is a blank TAB space for some reason. seems to be working fine now thanks !

Eric W · Mar 12, 2019

Glad to help!

Hope it works out for you.

shg · Mar 12, 2019

Another alternative: q-Gram Tetrahedral Ratio

[Table="width:, class:grid"][tr][td="bgcolor:#C0C0C0"][/td][td="bgcolor:#C0C0C0"]

A

[/td][td="bgcolor:#C0C0C0"]

B

[/td][td="bgcolor:#C0C0C0"]

C

[/td][td="bgcolor:#C0C0C0"]

D

[/td][td="bgcolor:#C0C0C0"]

E

[/td][/tr][tr][td="bgcolor:#C0C0C0"]

1

[/td][td="bgcolor:#F3F3F3"]

CM ADDRESS

[/td][td="bgcolor:#F3F3F3"]

ABC ADDRESS

[/td][td="bgcolor:#F3F3F3"]

Edit Dist

[/td][td="bgcolor:#F3F3F3"]

qTR

[/td][td][/td][/tr]
[tr][td="bgcolor:#C0C0C0"]

2

[/td][td]2380 BAYSIDE ST NAPLES FL 34112[/td][td]2380 BAYSIDE ST NAPLES FL 34112[/td][td]

100.00%

[/td][td="bgcolor:#CCFFCC"]

100.00%

[/td][td="bgcolor:#CCFFCC"]D2: =qTR(A2,B2)[/td][/tr]
[tr][td="bgcolor:#C0C0C0"]

3

[/td][td]3800 GRAND LN APT 206 TITUSVILLE FL 32780[/td][td]3800 GRAND LN APT 206 TITUSVILLE FL 32780[/td][td]

100.00%

[/td][td="bgcolor:#CCFFCC"]

100.00%

[/td][td][/td][/tr]
[tr][td="bgcolor:#C0C0C0"]

4

[/td][td]505 FERDINAND AVE DELTONA FL 32780[/td][td]5478 South St Sodus NY 14551-9542[/td][td]

8.82%

[/td][td="bgcolor:#CCFFCC"]

0.29%

[/td][td][/td][/tr]
[tr][td="bgcolor:#C0C0C0"]

5

[/td][td]10612 108TH ST LARGO FL 33778[/td][td][/td][td]

0.00%

[/td][td="bgcolor:#CCFFCC"]

0.00%

[/td][td][/td][/tr]
[tr][td="bgcolor:#C0C0C0"]

6

[/td][td]1449 SUGARBERRY LN SAINT CLOUD FL 34772[/td][td]3938 CEDAR HAMMOCK TRL SAINT CLOUD FL 34772[/td][td]

58.14%

[/td][td="bgcolor:#CCFFCC"]

14.59%

[/td][td][/td][/tr]
[tr][td="bgcolor:#C0C0C0"]

7

[/td][td]5004 BARNSTEAD DR RIVERVIEW FL 33578[/td][td][/td][td]

0.00%

[/td][td="bgcolor:#CCFFCC"]

0.00%

[/td][td][/td][/tr]
[tr][td="bgcolor:#C0C0C0"]

8

[/td][td]1871 NW SOUTH RIVER DR UNIT 17 MIAMI FL 33125[/td][td]108-136 MARTIN LUTHER KING JR BLVD APT 1317 NEWARK NJ 07104[/td][td]

33.90%

[/td][td="bgcolor:#CCFFCC"]

0.33%

[/td][td][/td][/tr]
[tr][td="bgcolor:#C0C0C0"]

9

[/td][td]581 OVAL CT APOPKA FL 32703[/td][td][/td][td]

0.00%

[/td][td="bgcolor:#CCFFCC"]

0.00%

[/td][td][/td][/tr]
[/table]

Code:

Function qTR(s1 As String, s2 As String) As Double
  ' code from http://gregholland.com/qTR.pdf,
  ' "q-Gram Tetrahedral Ratio (qTR) for Approximate Pattern Matching"

  Dim i             As Long
  Dim j             As Long
  Dim Q             As Long
  Dim n1            As Long
  Dim n2            As Long
  Dim Tn1           As Double
  Dim Tn2           As Double

  i = 1
  n1 = Len(s1)
  n2 = Len(s2)

  If n1 > 0 And n2 > 0 Then
    Do While i <= n1
      j = 1
      Do While j <= n1 - i + 1
        If InStr(1, s2, Mid(s1, i, j), vbTextCompare) Then Q = Q + j
        j = j + 1
      Loop
      i = i + 1
    Loop

    Tn1 = n1 * (n1 + 1) * (n1 + 2) / 6
    Tn2 = n2 * (n2 + 1) * (n2 + 2) / 6
    qTR = (n1 * Q / Tn1 + n2 * Q / Tn2) / (n1 + n2)
  End If
End Function

fokeiro · Mar 12, 2019

yeah eric it did, im going to read more into the lev distance, seems it can be apply on multiple types of cases. thanks for the info !!

Shg thanks for the info!!!! that's a great pdf to read on it. ill apply it too!

shg · Mar 12, 2019

You're welcome.

Compare addresses and show percentage of similarities

fokeiro

New Member

Excel Facts

Eric W

MrExcel MVP

Fluff

MrExcel MVP, Moderator

fokeiro

New Member

fokeiro

New Member

fokeiro

New Member

Eric W

MrExcel MVP

shg

MrExcel MVP

fokeiro

New Member

shg

MrExcel MVP

Similar threads

Forum statistics

Share this page

Compare addresses and show percentage of similarities

New Member

Excel Facts

MrExcel MVP

MrExcel MVP, Moderator

New Member

New Member

New Member

MrExcel MVP

MrExcel MVP

New Member

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock