最近做一个模糊匹配，看到一个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[j]，用temp记录它，为0。否则temp记为1。然后在矩阵d[j]赋于d[i-1][j]+1 、d[j-1]+1、d[i-1][j-1]+temp三者的最小值。
- 扫描完后，返回矩阵的最后一个值即d[n][m]
先上效果图
用法和VLOOKUP差不多，MYLOOKUP(被查询字段，查询范围，返回列，精准度）
注：这里的精准度是指，如果匹配结果精准度小于这个值，就不返回对应值）
附上原代码
[Visual Basic] 纯文本查看 复制代码 Public Function Levenshtein(str1 As String, str2 As String)
'str1或str2的长度为0返回另一个字符串的长度?
'初始化(n+1)*(m+1)的矩阵d，并让第一行和列的值从0开始增长。
'扫描两字符串（n*m级的），如果：str1[i] == str2[j]，用temp记录它，为0。否则temp记为1。然后在矩阵d[i][j]赋于d[i-1][j]+1 、d[i][j-1]+1、d[i-1][j-1]+temp三者的最小值。
'扫描完后，返回矩阵的最后一个值即d[n][m]
'最后1-d[n][m]/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[i] == str2[j] 即temp = 0则d[i][j] = d[i-1][j-1] + 0
Else '当str1[i] == str2[j] 不成立,那么即d[i][j] 与d[i-1][j] 或 d[i][j-1]+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
土豪附件通道
模糊查询.rar
(12.73 KB, 下载次数: 90)
| 
发表于 2020-10-21 19:56
|
发表于 2020-10-22 09:01
