"Meinten Sie ..."-Korrektur durch Zählen von Unterschieden

    • VBA: Excel

    Es gibt 1 Antwort in diesem Thema. Der letzte Beitrag () ist von petaod.

      "Meinten Sie ..."-Korrektur durch Zählen von Unterschieden

      Servus zusammen,
      in vielen Fällen ist es möglich, dass der Nutzer nach einem String gefragt wird und er dabei einen Tippfehler macht. Google fragt einen dann "Meinten Sie ...".
      Ich habe etwas Ähnliches in VBA realisiert.

      Für die Methode wird ein Array namens Dictionary angelegt in das man alle Begriffe hineinschreibt, die als Input erlaubt sind.
      Wenn man die Methode DidYouMeanDictionary aufruft, vergleicht er den der Methode übergebenen String mit jedem einzelnen Eintrag im Array Dictionary und zählt die Unterschiede. Die Methode gibt dann denjenigen Eintrag aus Dictionary zurück, der dem Input am ähnlichsten ist (also am wenigsten Unterschiede aufweist).

      Prinzipiell können beliebige Strings in beliebiger Anzahl mit den üblichen Methoden in das Array Dictionary geladen werden, hier ist (weil ich es in meinem Anwendungsfall so brauche) eine Methode LoadMonthsToDictionary, die die 12 Monate in das Array lädt mit dabei. Am Besten ist es jedoch, wenn der Anwendungsfall bereits auf wenige Begriffe reduziert ist, dann ist die Treffergenauigkeit auch höher.

      Bekannte Issues:
      -Wenn sich der Input und das Vergleichswort in der Länge unterscheiden, kann es unter Umständen zu falschen Angaben in der Statistik kommen, wenn man printStats auf true setzt.

      Hier der Source-Code (Unter Excel 2013 ausführlich getestet):

      Visual Basic-Quellcode

      1. Public Dictionary() As String
      3. Function countDifferences(str1 As String, str2 As String) As Long
      4. 'Counts the differences between str1 and str2 (different chars, removed chars, added chars)
      6. Dim lngC1CharLength As Long
      7. Dim CHARCHANGECOUNT As Long
      8. CHARCHANGECOUNT = 0
      9. For i = 1 To Application.WorksheetFunction.Max(Len(str1), Len(str2))
      10. If Len(str1) < Len(str2) Then
      11. If InStr(1, Mid(str2, i, 1 + Len(str2) - Len(str1)), Mid(str1, i, 1), vbTextCompare) = 0 Then
      12. CHARCHANGECOUNT = CHARCHANGECOUNT + 1
      13. End If
      14. ElseIf Len(str1) > Len(str2) Then
      15. If InStr(1, Mid(str2, Application.WorksheetFunction.Max(1, i - (Len(str1) - Len(str2))), 1 + Len(str1) - Len(str2)), Mid(str1, i, 1), vbTextCompare) = 0 Then
      16. CHARCHANGECOUNT = CHARCHANGECOUNT + 1
      17. End If
      18. Else
      19. If Mid(str1, i, 1) <> Mid(str2, i, 1) Then
      20. CHARCHANGECOUNT = CHARCHANGECOUNT + 1
      21. End If
      22. End If
      23. Next
      24. countDifferences = CHARCHANGECOUNT + Application.WorksheetFunction.Max(Len(str2) - Len(str1), 0)
      25. End Function
      27. Public Sub LoadMonthsToDictionary(Optional BeVerbose As Boolean = False)
      28. 'Loads a sample dictionary consisting of the german names for the months of a year.
      30. Dictionary = Split("Januar, Februar, März, April, Mai, Juni, Juli, August, September, Oktober, November, Dezember", ", ")
      31. If BeVerbose = True Then
      32. Debug.Print "Loaded the following words to the dictionary:"
      33. For Each word In Dictionary
      34. Debug.Print " " & word
      35. Next
      36. End If
      37. End Sub
      39. Public Function DidYouMeanDictionary(text As String, Optional printStats As Boolean = False) As String
      40. 'Compares text with every word in the dictionary using the countDifferences-function and returns the most similar word.
      41. 'This only works properly for single words.
      43. On Error GoTo Fehler
      45. Dim MinDiff, MinDiffIndex
      46. Dim DictString As String, DiffString As String
      48. MinDiff = countDifferences(text, Dictionary(0))
      49. MinDiffIndex = 0
      50. DictString = Dictionary(0) & " "
      51. DiffString = FormatNumber(countDifferences(text, Dictionary(i)), Len(Dictionary(i))) & " "
      52. For i = 1 To UBound(Dictionary)
      53. If MinDiff > countDifferences(text, Dictionary(i)) Then
      54. MinDiff = countDifferences(text, Dictionary(i))
      55. MinDiffIndex = i
      56. End If
      57. DictString = DictString & Dictionary(i) & " "
      58. DiffString = DiffString & FormatNumber(countDifferences(text, Dictionary(i)), Len(Dictionary(i))) & " "
      59. Next i
      60. DidYouMeanDictionary = Dictionary(MinDiffIndex)
      61. If printStats = True Then
      62. Debug.Print ""
      63. Debug.Print "Analysis stats: Differences between " & text & " and ..."
      64. Debug.Print DictString
      65. Debug.Print DiffString
      66. Debug.Print ""
      67. Debug.Print "Chars to be added to get from " & text & " to " & Dictionary(MinDiffIndex) & ": " & Application.WorksheetFunction.Max(Len(Dictionary(MinDiffIndex)) - Len(text), 0)
      68. Debug.Print "Chars to be removed to get from " & text & " to " & Dictionary(MinDiffIndex) & ": " & Application.WorksheetFunction.Max(Len(text) - Len(Dictionary(MinDiffIndex)), 0)
      69. Debug.Print "Chars to be exchanged to get from " & text & " to " & Dictionary(MinDiffIndex) & ": " & Application.WorksheetFunction.Max(MinDiff - Application.WorksheetFunction.Max(Len(text) - Len(Dictionary(MinDiffIndex)), 0) - Application.WorksheetFunction.Max(Len(Dictionary(MinDiffIndex)) - Len(text), 0), 0)
      70. Debug.Print ""
      71. End If
      72. Exit Function
      73. Fehler:
      74. Err.Raise 1234, "CountDifferences", "No Dictionary is specified. Please specify a dictionary by filling the global array 'Dictionary' with values." & vbCrLf & vbCrLf & "Exact error description:" & vbCrLf & Err.Description
      75. End Function
      77. Public Function FormatNumber(num As Double, length As Long) As String
      78. 'Adds zeros in front of the number num sothat it meets the given length.
      79. For i = 1 To length - Len(CStr(num))
      80. FormatNumber = FormatNumber & " "
      81. Next i
      82. FormatNumber = FormatNumber & CStr(num)
      83. End Function


      Viele Grüße,
      vatbub