Tony Ciconte <to******@comca st.net> wrote:
: Does anyone know of or have any VBA code or similar logic that can
: help distinguish similar first/last name combinations? For example, we
: would like to prompt the user of a possible match when any of the
: first/last names Robert Smith, or Bob Smith, or Robt. Smith are used
: during data entry. All that is necessary is to alert the user so that
: they can review any appropriate existing records.
I wrote *very crude* code for this: it matches the alphanumeric
content of strings, *without any regard for order*, so although it
often works very well, you'll find some real howlers.
It sets a threshhold for matching that you can of course change.
Here's my code; excuse the numbers at the beginning of each line:
I got it from an Access export file before I learned how to export the
code alone.
--thelma
-----------------------------------------------------------------------
'------------------------------------------------------------------'
' RATEMATCH '
'------------------------------------------------------------------'
Function ratematch(ByVal listmember As String, _
ByVal guess As String) As Integer
372 '------------------------------------------------------------'
373 ' This Function computes a very crude 'match'-score for a '
374 ' tablemember as compared with a user entry that matched '
' no table member. It counts the alphanumeric characters '
' shared by the two, ignoring order and non alphanumeric '
' characters, but not collapsing duplicates. '
' Function Return: '
' 0=>match unlikely; 1=>exact match 2=>could be match '
378 '------------------------------------------------------------'
379
382
383 Dim guessLen As Integer
398 Dim gpos As Integer
399 Dim i As Integer
400 Dim lenNow As Integer
384 Dim ListMemberLen As Integer
401 Dim match As Integer
402 Dim nexletter As String
420 Dim mFrac As Single
380 listmember = _
OnlyAlphaNumeri cChars(listmemb er) ' Remove nonalphanumeric s
381 guess = _
OnlyAlphaNumeri cChars(guess) ' from strings to compare
386 ratematch = 0 ' Not a Match
388 ListMemberLen = Len(listmember) ' Length of String from List
389 If ListMemberLen = 0 Then _
Exit Function ' Null is not Valid Guess
391 guessLen = Len(guess) ' Length of User Input
393 If InStr(listmembe r, guess) = 1 And ListMemberLen = guessLen Then
394 ratematch = 1 ' Exact alphanumeric Match
395 Exit Function
396 End If
397
404 match = 0
405
406 For i = 1 To guessLen
407 lenNow = Len(listmember)
408 If lenNow = 0 Then Exit For ' No string left to search
409 nexletter = Mid(guess, i, 1)
410 gpos = InStr(listmembe r, nexletter) ' Seek char in table entry
411 If gpos > 0 Then ' Char Found
412 match = match + 1 ' Increment matchcount
413 listmember = _
414 Left(listmember , gpos - 1) & _
415 Right(listmembe r, lenNow - gpos) ' Remove char matched
416 End If
417 Next
418
419 ' Accept if Fraction of name matched >= mFrac
421 If ListMemberLen > 4 And guessLen > 4 Then
422 mFrac = 0.8
423 Else
424 mFrac = 0.75
425 End If
426
427 If ListMemberLen > 0 And guessLen > 0 Then
428 If match / ListMemberLen >= mFrac And _
match / guessLen >= mFrac Then
429 ratematch = 2 ' Acceptable Alphanum Match
430 End If
431 End If
432
433 End Function
435 Public Function OnlyAlphaNumeri cChars(ByVal OrigString As _
436 String) As String
437
438 '------------------------------------------'
439 ' I found this function on the internet: '
440 ' DevX.com '
441 '
http://www.freevbcode.com/ '
442 ' Author: Intelligent Solutions Inc. '
443 '------------------------------------------'
444
445 '************** *************** *************** ***************
446 'INPUT: Any String
447 'OUTPUT: The Input String with all non-alphanumeric characters
448 ' removed
449 '************** *************** *************** ***************
450 Dim lLen As Long
451 Dim sAns As String
452 Dim lCtr As Long
453 Dim sChar As String
454 Dim zap As Boolean
455
456
457 OrigString = Trim(OrigString )
458 lLen = Len(OrigString)
459
460 zap = OrigString Like "*[!0-9A-Za-z]*"
461 If zap = False Then
462 OnlyAlphaNumeri cChars = OrigString
463 Exit Function
464 End If
465
466 For lCtr = 1 To lLen
467 sChar = Mid(OrigString, lCtr, 1)
468 ' If IsAlphaNumeric( Mid(OrigString, lCtr, 1)) Then
469 If sChar Like "[0-9A-Za-z]" Then
470 sAns = sAns & sChar
471 End If
472 ' DoEvents '(optional, but if processing long string,
473 'necessary to prevent program from appearing to hang)
474 'if used, write your app so no re-entrancy into this function
475 'can occur)
476 Next
477
478 OnlyAlphaNumeri cChars = sAns
479
480 End Function
481
482 Private Function IsAlphaNumeric( sChr As String) As Boolean
483 IsAlphaNumeric = sChr Like "[0-9A-Za-z]"
484 End Function
485
-----------------------------------------------------------------------
: We have done several google searches without any luck. Any and all
: help is appreciated.
: TC
