אופיס 365 איך בודקים באקסס אחוזי התאמה בין שני שדות טקסט

[יאיר משה]

אני רוצה לבדוק את אחוזי ההתאמה בין שני שדות טקסט, כדי למצוא שגיאות בנתונים. איך כותבים זאת באקסס?
תודה מראש

 

[FullTime]

מה זה אחוזי התאמה?

 

[יאיר משה]

לדוגמא - אם בשדה א' כתוב "חיים אוחיון" ובשדה ב' כתוב "חים אוחיום" ההתאמה היא של 80 אחוז (ובמקרה זה, זה אומר שהנתונים תואמים רק ההקלדה של השם לא היתה מדוייקת).

אבל אם בשדה א' כתוב "חיים אוחיון" ובשדה ב' כתוב "יצחק גמליאל" ההתאמה היא 40 אחוז וזה אומר ששילוב הנתונים אינו נכון.

תודה

 

[moishy]

יש כמה אפשרויות.

Option Explicit

Private b1() As Byte
Private b2() As Byte

Public Function Simil(String1 As String, String2 As String) As Double
    Dim l1 As Long
    Dim l2 As Long
    Dim l As Long
    Dim r As Double
    If UCase(String1) = UCase(String2) Then
        r = 1
    Else
        l1 = Len(String1)
        l2 = Len(String2)
        If l1 = 0 Or l2 = 0 Then
            r = 0
        Else
            ReDim b1(1 To l1): ReDim b2(1 To l2)
            For l = 1 To l1
                b1(l) = Asc(UCase(Mid(String1, l, 1)))
            Next
            For l = 1 To l2
                b2(l) = Asc(UCase(Mid(String2, l, 1)))
            Next
            r = SubSim(1, l1, 1, l2) / (l1 + l2) * 2
        End If
    End If
    Simil = r
    Erase b1
    Erase b2
End Function

Private Function SubSim(st1 As Long, end1 As Long, st2 As Long, end2 As Long) As Long
    Dim c1 As Long
    Dim c2 As Long
    Dim ns1 As Long
    Dim ns2 As Long
    Dim i As Long
    Dim max As Long
    If st1 > end1 Or st2 > end2 Or st1 <= 0 Or st2 <= 0 Then Exit Function
    For c1 = st1 To end1
        For c2 = st2 To end2
            i = 0
            Do Until b1(c1 + i) <> b2(c2 + i)
                i = i + 1
                If i > max Then
                    ns1 = c1
                    ns2 = c2
                    max = i
                End If
                If c1 + i > end1 Or c2 + i > end2 Then Exit Do
            Loop
        Next
    Next
    max = max + SubSim(ns1 + max, end1, ns2 + max, end2)
    max = max + SubSim(st1, ns1 - 1, st2, ns2 - 1)
    SubSim = max
End Function

ותקרא לו כך:

Percent = Simil("חים אוחיום", "חיים אוחיון") * 100 & "%"

או כך:

Percent = Simil("חים אוחיום", "חיים אוחיון")

או:

Option Explicit

Public Function Simil(strTxt1 As String, strTxt2 As String) As Double

    Dim intTot As Integer
    Dim strMatch As String

    intTot = Len(strTxt1 & strTxt2)

    strMatch = GetBiggest(strTxt1, strTxt2)

    Simil = CDbl(Len(strMatch) * 2) / CDbl(intTot)

End Function

Public Function GetBiggest(strTxt1 As String, strTxt2 As String) As String

    Dim intLang    As Integer
    Dim intKort    As Integer
    Dim intPos     As Integer
    Dim intX       As Integer
    Dim strLangste As String
    Dim strSearch  As String
    Dim strLang    As String
    Dim strKort    As String
    Dim strTotal1 As String
    Dim strTotal2 As String
    
    intKort = Len(strTxt1)
    intLang = Len(strTxt2)
    
    If intLang > intKort Then
        strLang = strTxt2
        strKort = strTxt1
    ElseIf intKort = 0 Or intLang = 0 Then
        Exit Function
    Else
        strLang = strTxt1
        strKort = strTxt2
        intX = intKort
        intKort = intLang
        intLang = intX
    End If
        
    For intPos = 1 To intKort 'Compare string based on the shortest.
        intX = 0
        Do
            intX = intX + 1
            strSearch = Mid$(strKort, intPos, intX) 'Determine part of string to search for
            If Len(strSearch) <> intX Then
                Exit Do 'end of string
            End If
        Loop While InStr(1, strLang, strSearch) > 0 'Part of string found in other string, increase size of partstring and try again.
        intX = intX - 1
        If intX > Len(strLangste) Then 'Longest substring found
            strLangste = Mid$(strKort, intPos, intX)
        End If
        If intX = 0 Then intX = 1
        intPos = intPos + intX - 1
    Next intPos

    If Len(strLangste) = 0 Then
        GetBiggest = "" 'No matching substring found
    Else 'Substring match found.
        'Split substring in left and right part.
        strTotal1 = Replace(strTxt1, strLangste, "|")
        strTotal2 = Replace(strTxt2, strLangste, "|")
            
        'Recursive part: Try again and paste result to returnvalue.
        GetBiggest = strLangste & _
                        GetBiggest(CStr(Split(strTotal1, "|")(0)), CStr(Split(strTotal2, "|")(0))) & _
                        GetBiggest(CStr(Split(strTotal1, "|")(1)), CStr(Split(strTotal2, "|")(1)))
    End If
    
End Function

וקוראים לו באותה צורה.

 

[יאיר משה]

כל הכבוד!! זה עובד. ידעתי שיש לי על מי לסמוך (חוץ מעל הקב"ה כמובן).
אבל איך עושים שבטפסים רציפים לכל אחד יופיע הנתון שלו, ולא כל פעם שעוברים מרשומה לרשומה זה יתעדכן.
תודה רבה

 

[יאיר משה]

הסתדרתי, פשוט רשמתי את את הפקודה במקור הפקד של השדה.
שוב תודה