find almost matching data

[ndeeley]

Hi there,

I have two tables with site information. There's a field in each for the site name, with sites from a - z. Unfortunately the site name isn't quite an exact match between tables:

Common_List.EquipmentDesc

ADMIRALTY SR, TORPOINT
ALLERS WPS, TIVERTON
BARLEY LANE SR, EXETER
...

SList.SiteDesc
ADMIRALTY SR
ALLERS WPS TIVERTON
BARLEY LANE SR (EXETER)
...

All the strings are of different lengths, have various numbers of words etc. Is there a way to get Access to compare say, the first word of one table with another, and output the matches?

Thanks for you help!

[TheSmileyCoder]

There are various ways this can be done. The simplest involves checking the first X charecters of each string to each other. This can be done by writing your query in the query design window, swithcing to SQL view and look at the join statement.

It will look something like this:

ON Common_List.EquipmentDesc=SList.SiteDesc

Modify it to read like this:

ON Left(Common_List.EquipmentDesc,4)=Left(SList.SiteDesc,4)

Replace 4 with however many charecters you want to use. You may need to replace , with ;, depending on your computers regional settings.

A more advanced way would be to split based on the first space.

ON Split(Common_List.EquipmentDesc," ")(0)=Split(SList.SiteDesc," ")(0)

With all that said and done to answer your immediate question, I must strongly emphazise that unless this is data coming in from sources over which you have no control (Such as external Database, or excel spreadsheets) you need to prevent this thing from ever happening in the first place.

You need to define the acceptable list of Descriptions and put them in a seperate table, and include a combobox in your forms, referencing that table. That way you will not get these kind of erros where even a simple type can mess up your results. For more information try reading: Database normalisation and table structures

[NeoPa]

As Smiley says, this is a situation to avoid. Solving all the problems are likely to take you many days of work, and that's assuming you have a brain capable of working out a way to handle it. No disrespect to your brain - I know nothing about that after all - but very very few can handle creating the logic to compare such data reliably. I know, as I managed a decent approximation once and it was extraordinarily complex.

[Mihail]

A very long time ago I design a program to do exactly what you need now (for my hobby).
Since my program had worked on a Spectrum computer (HC) with a Z80 processor (is anyone who remember this toys ? ) I can't give you more than an idea:

As long as I remember my approach was:

For Each STR_1 in FirstString
    'I define a variable to store the muched percent
     'and I initialize it with ZERO
    MatchedPercent = 0
    'and a string variable to store the AlmostMatchedString
    'and I initialize it with "" (zero length)
    AlmostMatchedString = ""
    'then:
    For Each STR_2 in SecondStrings
        'FullSTR_2=STR_2 'Store the value for further use
        'I store the total length of strings
        FirstTotalLength = LEN(Str_1) + LEN(Str_2)
        'Then I eliminate all characters that not matched
         between strings.
        Call EliminateNotMatchedChars(Str_1, Str_2)
        'I calculate the new total length:
        NewTotalLength = LEN(Str_1) + LEN(Str_2)
        'and the new matched percent
        NewMatchedPercent = NewTotalLength / FirstTotalLength
        'I compare the new matched percent with
        'the preview one
        IF NewMatchedPercent > MatchedPercent THEN
            'Store the higher percent
            MatchedPercent = NewMatchedPercent
            'Store the string with higher matched percent
            AlmostMatchedString = FullSTR_2
         END IF
    NEXT STR_2
    'Here you have the STR_2 with the top matched percent
    'with STR_1
    Debug.Print STR_1, FullSTR_2
NEXT STR_1

Of course you can't be 100% sure that the program find exactly you need.

I think that is not a problem for you to design the EliminateNotMatchedChars subroutine.

Good luck !

[Mariostg]

Assuming you do some data clean up to ease the job by stripping out any coma, period, parenthesis etc, you could adapt the following.
Here it runs an two arrays, but the process is similar for two recordsets.
You need Microsoft VBScript Regular Expression Reference enabled.

Function findPartialMatch()
    Dim re As New RegExp
    Dim pattern As String
    Dim arr1, a1 As Variant
    Dim arr2, a2 As Variant
    re.Global = True
    arr1 = Array("ADMIRALTY SR TORPOINT", "ALLERS WPS TIVERTON", "BARLEY LANE SR EXETER")
    arr2 = Array("ADMIRALTY SR", "ALLERS WPS TIVERTON", "BARLEY LANE SR EXETER")
    Debug.Print "---Search for elements of array arr1 in array arr2---"
    For Each a1 In arr1
        re.pattern = a1
        For Each a2 In arr2
            If (re.test(a2) = True) Then
                Debug.Print a1 & " matched in " & a2
            End If
        Next a2
    Next a1
    Debug.Print "---Search for elements of array arr2 in array arr1---"
    For Each a2 In arr2
       re.pattern = a2
       For Each a1 In arr1
           If (re.test(a1) = True) Then
               Debug.Print a2 & " matched  " & a1
           End If
       Next a1
    Next a2
 
End Function
 

Output:

---Search for elements of array arr1 in array arr2---
ALLERS WPS TIVERTON matched in ALLERS WPS TIVERTON
BARLEY LANE SR EXETER matched in BARLEY LANE SR EXETER
---Search for elements of array arr2 in array arr1---
ADMIRALTY SR matched  ADMIRALTY SR TORPOINT
ALLERS WPS TIVERTON matched  ALLERS WPS TIVERTON
BARLEY LANE SR EXETER matched  BARLEY LANE SR EXETER
 

[Mihail]

@Mariostg
I think that your code can be translated to use regular function InStr(). So no need to add new library to refer to.
This was a comment not the purpose for this post

From what I see from your results the code find a perfect match between one string and a part (piece) from the other one.
What happen if a perfect match can't be find ?

Example:
Str_1 = ALLERS WPS TIVERTON
Str_2 = TIVERTON WPS ALLERS

[Mariostg]

I always forget about the InStr() function. Regular expressions is what pop up in my head first when I saw the post.
Indeed, with the two strings you proposed that won't work. I just based my function on the few liners given by the OP. To expend what I wrote, each of a1 and a2 would probably need to have each of their words sorted. i.e. a1 ->split -> sort array -> join array back into string then compare after doing the same with a2.

If only Access had some of Python abilities. Just dreaming. As Neopa said, there is lots of brain work involved there. I would strongly consider the closing part of Smiley's post.

[questprince]

Check this out......

ChangeValueTableName: Put the name of table where record has to be compared and changed.

ChangeValueTableFieldName: Name of the field in the ChangeValueTableName where record has to be compared and changed.

CorrectTableName: Put the name of table to which record has to be compared.

CorrectTableFieldName: Name of the field in the CorrectTableFieldName to which record is to be compared.

SensiivityFactor: Value between 1 to 99. Increase the sensitivity as per your need.

Public Function PercentRelation(ByVal ChangeValueTableName As String, _
ByVal ChangeValueTableFieldName As String, _
ByVal CorrectTableName As String, _
ByVal CorrectTableFieldName As String, _
ByVal SensitivityFactor As Double)
 
Dim TString As String
Dim OString As String
Dim TCount As Double
Dim OCount As Double
Dim XT As Double
Dim XO As Double
Dim TEach As String
Dim OEach As String
Dim RPercent As Double
Dim TPercent As Double
Dim PMatch As Double
Dim TMatch As Double
Dim FMatch As Double
Dim NewMatchFound As Double
Dim Eval As String
Dim XSense As Double
Dim CRecords As Double
Dim TRecords As Double
 
XSense = SensitivityFactor
CRecords = 0
Dim dbs As Database
Dim rstUserPwd As Recordset
 
Set dbs = CurrentDb
Set rstUserPwd = dbs.OpenRecordset(ChangeValueTableName)
 
TRecords = dbs.OpenRecordset(ChangeValueTableName).RecordCount
 
If rstUserPwd.RecordCount > 0 Then
   rstUserPwd.MoveFirst
 
Do While rstUserPwd.EOF = False
 
NewMatchFound = 0
FMatch = 0
 
'*******************************************************************************
Dim dbsF As Database
Dim rstUserPwdF As Recordset
 
Set dbsF = CurrentDb
Set rstUserPwdF = dbsF.OpenRecordset(CorrectTableName)
 
If rstUserPwdF.RecordCount > 0 Then
   rstUserPwdF.MoveFirst
 
Do While rstUserPwdF.EOF = False
'*******************************************************************************
Dim TPlace As String
Dim OPlace As String
 
TPlace = rstUserPwd(ChangeValueTableFieldName)
OPlace = rstUserPwdF(CorrectTableFieldName)
 
If Left$(TPlace, 1) <> Left$(OPlace, 1) Then
GoTo jump
End If
 
'*******************************************************************************
TString = TPlace
OString = OPlace
 
TCount = Len(TString)
OCount = Len(OString)
 
RPercent = 100 / OCount
TPercent = 100 / TCount
PMatch = 0
TMatch = 0
 
XT = 1
 
Do Until XT > TCount
 
XO = 1
 
TEach = Mid$(TString, XT, 1)
 
Do Until XO > OCount
 
OEach = Mid$(OString, XO, 1)
 
If OEach = TEach Then
PMatch = PMatch + RPercent
TMatch = TMatch + TPercent
 
If XO = 1 Then
OString = Right(OString, Len(OString) - 1)
Else
OString = Left$(OString, XO - 1) & Right$(OString, Len(OString) - XO)
End If
 
XO = 1
OCount = Len(OString)
Exit Do
Else
XO = XO + 1
End If
 
Loop
 
XT = XT + 1
Loop
 
FMatch = Round((PMatch + TMatch) * 0.5, 1)
 
'*******************************************************************************
If NewMatchFound < FMatch Then
NewMatchFound = FMatch
Eval = OPlace
End If
jump:
rstUserPwdF.MoveNext
Loop
End If
 
 
'*******************************************************************************
 
If NewMatchFound > XSense Then
rstUserPwd.Edit
rstUserPwd(ChangeValueTableFieldName) = Eval
rstUserPwd.Update
CRecords = CRecords + 1
End If
 
rstUserPwd.MoveNext
Loop
End If
MsgBox CRecords & " records matched out of " & TRecords & " records."