[VBA]模糊度匹配

keate23 发表于 2020-10-21 19:56

最近做一个模糊匹配，看到一个Levenshtein Distance(LD)算法，但是又没有看到有VBA的相关写法，所以就做写了一个类似VLOOKUP的函数，在这里分享给大家

首先介绍一下这个算法：

简单介绍下Levenshtein Distance(LD)：LD 可能衡量两字符串的相似性。它们的距离就是一个字符串转换成那一个字符串过程中的添加、删除、修改数值。
举例：

[*]如果str1="test"，str2="test"，那么LD(str1,str2) = 0。没有经过转换。
[*]如果str1="test"，str2="tent"，那么LD(str1,str2) = 1。str1的"s"转换"n"，转换了一个字符，所以是1。

如果它们的距离越大，说明它们越是不同。
Levenshtein distance最先是由俄国科学家Vladimir Levenshtein在1965年发明，用他的名字命名。不会拼读，可以叫它edit distance（编辑距离）。
Levenshtein distance可以用来：

[*]Spell checking(拼写检查)
[*]Speech recognition(语句识别)
[*]DNA analysis(DNA分析)
[*]Plagiarism detection(抄袭检测)

LD用m*n的矩阵存储距离值。算法大概过程：

[*]str1或str2的长度为0返回另一个字符串的长度。
[*]初始化(n+1)*(m+1)的矩阵d，并让第一行和列的值从0开始增长。
[*]扫描两字符串（n*m级的），如果：str1 == str2，用temp记录它，为0。否则temp记为1。然后在矩阵d赋于d+1 、d+1、d+temp三者的最小值。
[*]扫描完后，返回矩阵的最后一个值即d

先上效果图

用法和VLOOKUP差不多，MYLOOKUP(被查询字段，查询范围，返回列，精准度）
注：这里的精准度是指，如果匹配结果精准度小于这个值，就不返回对应值）
附上原代码
Public Function Levenshtein(str1 As String, str2 As String)
'str1或str2的长度为0返回另一个字符串的长度?
'初始化(n+1)*(m+1)的矩阵d，并让第一行和列的值从0开始增长。
'扫描两字符串（n*m级的），如果：str1 == str2，用temp记录它，为0。否则temp记为1。然后在矩阵d赋于d+1 、d+1、d+temp三者的最小值。
'扫描完后，返回矩阵的最后一个值即d
'最后1-d/max(n,m)为匹配率,匹配率越高说明距离越短
Dim i As Integer
Dim j As Integer
Dim l1 As Integer
Dim l2 As Integer
Dim d() As Integer
Dim min1 As Integer
Dim min2 As Integer
Dim max As Integer
Dim matchRate As Double

matchRate = 0
l1 = Len(str1)
l2 = Len(str2)
ReDim d(l1, l2)
For i = 0 To l1
d(i, 0) = i
Next
For j = 0 To l2
d(0, j) = j
Next
For i = 1 To l1
For j = 1 To l2
   If Mid(str1, i, 1) = Mid(str2, j, 1) Then
         d(i, j) = d(i - 1, j - 1) '当str1 == str2 即temp = 0则d = d + 0
   Else '当str1 == str2不成立,那么即d 与d 或 d+1 距离都为1,此时取最小的那个
         min1 = d(i - 1, j) + 1
         min2 = d(i, j - 1) + 1
         If min2 < min1 Then
            min1 = min2
         End If
         min2 = d(i - 1, j - 1) + 1
         If min2 < min1 Then
            min1 = min2
         End If
         d(i, j) = min1
   End If
Next
Next
If l1 > l2 Then
max = l1
Else
max = l2
End If
matchRate = Round(1 - d(l1, l2) / max, 6)

Levenshtein = matchRate
End Function

Public Function MYLOOKUP(ByVal lookup_value As String, ByVal table_array As Range, ByVal col_index_num As Integer, ByVal matchRate As Double)
Dim i As Long
Dim rate As Double
MaxRate = matchRate
MYLOOKUP = CVErr(xlErrNA)
For i = 1 To table_array.Rows.Count
   If lookup_value = table_array.Cells(i - 1, 1) Then
         MYLOOKUP = table_array.Cells(i - 1, col_index_num)
         Exit For
   End If
   rate = Levenshtein(lookup_value, table_array.Cells(i - 1, 1))
   If rate >= MaxRate Then
         MYLOOKUP = table_array.Cells(i - 1, col_index_num)
   End If
Next i
'If IsEmpty(MYLOOKUP) Then MYLOOKUP = Null
End Function

土豪附件通道

keate23 发表于 2020-10-22 09:01

Su、发表于 2020-10-21 21:24
这种是与原文相同字数，其实我一直有想过
假设原文是：吾爱破解。
用户输入是：我是吾爱用户。

语义分析那是一个另外领域,接近AI了

君如兰 发表于 2020-10-21 21:35

Su、发表于 2020-10-21 21:24
这种是与原文相同字数，其实我一直有想过
假设原文是：吾爱破解。
用户输入是：我是吾爱用户。

语义分析就有点牛逼了{:301_998:}

lizhipei78 发表于 2020-10-21 20:06

看了一下，用Excel写了模块，但是不会用

sunxuewei888 发表于 2020-10-21 20:18

看看，学习学习

水吉空 发表于 2020-10-21 20:36

不错的东西

紫藤，飘零叶 发表于 2020-10-21 20:56

厉害厉害

chunhwa 发表于 2020-10-21 21:02

谢谢分享

fttaiy 发表于 2020-10-21 21:21

学习一下，哈哈。不错不错哦

Su、 发表于 2020-10-21 21:24

这种是与原文相同字数，其实我一直有想过
假设原文是：吾爱破解。
用户输入是：我是吾爱用户。
这样准确率怎么计算

zz1181 发表于 2020-10-21 21:52

学习一下，谢谢

页: [1] 2

吾爱破解 - 52pojie.cn's Archiver

[VBA]模糊度匹配