Quack Boy <qu***@nottelling.co.uk> wrote in message news:<nr********************************@4ax.com>. ..
I'm new to MS Access (97) and I need for a query to find *near*
matches (not exact duplicates) mainly to weed out duplicates that may
contain similar erronious data.
EG Table1
Name Company Town
Alan ABC Alphaville
Brian B inc. Beta City
Calan ABC Alpaville
where the result would return
Alan
Calan
when searching by "name" or
Alphaville
Alpaville
when doing a near match query by "town"
Or if there is a way that that the whole table could be searched to
find near matches that would help.
Thank you.
You can use either SimilCmp or LD both included, SimilCmp is faster.
have fun.
tom
Public Function LD(ByVal s As String, ByVal t As String) As Integer
Dim d() As Integer ' matrix
Dim ks As Integer ' length of Known word
Dim ms As Integer ' length of Match word
Dim ki As Integer ' Known word index
Dim mi As Integer ' Match word index
Dim kc As String ' Known character
Dim mc As String ' Match character
Dim cost As Integer ' cost
Dim a As Integer '
Dim b As Integer '
Dim c As Integer '
' Step 1
ks = Len(s) ' set Known word length
ms = Len(t) ' set Match word length
If ks = 0 Then ' if no Known word
LD = ms ' return length of Match
word
Exit Function ' bail out
End If ' if no Known word
If ms = 0 Then ' if no Match word
LD = ks ' return length of Known
word
Exit Function ' bail out
End If ' if no Match word
ReDim d(0 To ks, 0 To ms) As Integer ' build matrix based on
length of Known and Match words
' Step 2
For ki = 0 To ks ' Known word loop
d(ki, 0) = ki ' load Known word index into
matrix, vertically
Next ki ' next index of known word
For mi = 0 To ms ' Known Match loop
d(0, mi) = mi ' load Match word index into
matrix, horizontally
Next mi ' next index of Match word
For ki = 1 To ks ' Known word loop
kc = Mid$(s, ki, 1) ' get character of Known
word
For mi = 1 To ms ' Match word loop
mc = Mid$(t, mi, 1) ' get character of Match
word
If kc = mc Then ' if character from Known
and Match words NOT the same
cost = 0 ' set cost to 0
Else ' if character from Known
and Match words the same
cost = 1 ' set cost to 0
End If ' if character from Known
and Match words the same
a = d(ki - 1, mi) + 1
b = d(ki, mi - 1) + 1
c = d(ki - 1, mi - 1) + cost
If b < a Then a = b
If c < a Then
d(ki, mi) = c
Else
d(ki, mi) = a
End If
' d(ki, mi) = Minimum(d(ki - 1, mi) + 1, d(ki, mi - 1) + 1, d(ki -
1, mi - 1) + cost)
Next mi ' next Match word character
Next ki ' next Known word character
LD = d(ks, ms) ' return distance
Erase d ' free array
End Function
Public Function SimilCmp(Known As String, Match As String) As Single
Dim k() As Byte ' Known word array
Dim m() As Byte ' Match word array
Dim ks As Integer ' Known string length
Dim ms As Integer ' Match string length
ks = Len(Known): ms = Len(Match) ' initialize Known and
Match string lengths
If ks = 0 Or ms = 0 Then Exit Function ' if Known or Match are
empty, return 0%
If Known = Match Then ' if strings the same
SimilCmp = 100 ' return 100%
Else ' if strings are NOT the
same
k = StrConv(UCase(Known), vbFromUnicode) ' load Known array
m = StrConv(UCase(Match), vbFromUnicode) ' load Match array
SimilCmp = GcSubStr(k(), 0, ks, m(), 0, ms) ' get number of matching
characters
SimilCmp = (200 * SimilCmp / (ks + ms)) ' calculate precentage
Erase k ' free array resources
Erase m ' free array resources
End If ' if strings match
End Function
Private Function GcSubStr(k() As Byte, ko As Integer, ks As Integer,
m() As Byte, mo As Integer, ms As Integer) As Long
Dim ki As Integer ' Known string index
Dim mi As Integer ' Match string index
Dim kn As Integer ' Known next index
Dim mn As Integer ' Match next index
Dim kl As Integer ' Known next length
Dim ml As Integer ' Match next length
Dim cc As Integer ' current concurrent
character count
Dim ci As Integer ' concurrent character
index
' If no more substing to compare, return 0
If (ks <= ko Or ms <= mo) Then Exit Function ' if Known or Match
index is past end of string
If (ks = ko + 1 And ms = mo + 1) Then Exit Function ' if last
character of Known and Match strings
cc = 0: kl = ks: ml = ms: ' initialize concurrent
character count and string lengths
ki = ko ' initialize Known index
While (ki < kl) ' Known string loop
mi = mo ' initialize Match index
While (mi < ml) ' Match string loop
If (k(ki) = m(mi)) Then ' if a character the
same in both strings
ci = 1 ' initialize concurrent
character index
Do Until ((ki + ci >= kl) Or (mi + ci >= ml)) ' while things
match, keep trying...
If (k(ki + ci) <> m(mi + ci)) Then Exit Do ' if things NOT
matching, break loop
ci = ci + 1 ' bump concurrent
character count
Loop ' next character match
If ci > cc Then ' if concurrent count >
greatest count
cc = ci: kn = ki: mn = mi ' save indexes and
greatest count
kl = ks - cc: ml = ms - cc ' save indexes and
greatest count
End If ' if concurrent count >
greatest count
End If ' if a character the
same in both strings
mi = mi + 1 ' bump Match index
Wend ' next Match character
ki = ki + 1 ' bump Known index
Wend ' next Known character
If cc = 0 Then Exit Function ' return 0
cc = cc + GcSubStr(k(), kn + cc, ks, m(), mn + cc, ms) ' check right
hand side
cc = cc + GcSubStr(k(), ko, kn, m(), mo, mn) ' check left hand side
GcSubStr = cc ' return matched
character count of substrings
End Function