2列字符对比

zhihaizhiai

各位大侠，有2列字符对比，从A列找出和I列一样的，返回别的相应A列对应的别的列值，如果不同，进行相似度匹配（网上找的匹配程序，调用），匹配度大于.7的也找出来，程序运行近5个小时才结束。各位大侠帮助优化一下。谢谢。

筛选代码：

Private Sub CommandButton1_Click()
Dim aa$   '词包
Dim bb$   '语句
Dim cc  '词包匹配单个语句变量
Dim cccc '词包匹配语句计数器

Dim dd '词包行数
Dim ee '语句行数

Dim ff
Dim ii '语句行数
Dim iiii '词包行数


Dim gg '词包匹配计数器

Dim tt
Dim tttt
Dim tm


Dim xx, yy, xxx, yyy, xxxx, yyyy


tm = Now()

dd = 1 '写词包行数
ee = 1 '写语句行数



For iiii = 1 To 4514  '词包循环
aa = Cells(iiii, 9)

For ii = 1 To 11285   '语句循环
bb = Cells(ii, 1)

If aa = bb Then

Cells(iiii, 15) = Cells(ii, 3)
Cells(iiii, 16) = Cells(ii, 4)
Cells(iiii, 17) = Cells(ii, 6)

ElseIf sim(aa, bb) > 0.7 Then

Cells(iiii, 19) = Cells(ii, 3)
Cells(iiii, 20) = Cells(ii, 4)
Cells(iiii, 21) = Cells(ii, 6)
Cells(iiii, 22) = Cells(ii, 1)

Else


End If

Next ii

Next iiii

MsgBox "程序结束，请查看结果,耗时:" & Format(Now() - tm, "hh:mm:ss")

'MsgBox "程序结束，请查看结果", , "提示"


End Sub





对比相似度（网上找的）

Private Function min(one As Integer, two As Integer, three As Integer)
    min = one
    If (two < min) Then
     min = two
    End If
    If (three < min) Then
     min = three
    End If
End Function

Private Function ld(str1 As String, str2 As String)
Dim n, m, i, j As Integer
Dim ch1, ch2 As String
    n = Len(str1)
    m = Len(str2)
    Dim temp As Integer
    If (n = 0) Then
        ld = m
    End If
    If (m = 0) Then
        ld = n
    End If
Dim d As Variant
ReDim d(n + 1, m + 1) As Variant
    For i = 0 To n
        d(i, 0) = i
    Next i
    For j = 0 To m
        d(0, j) = j
    Next j
    For i = 1 To n
        ch1 = Mid(str1, i, 1)
        For j = 1 To m
            ch2 = Mid(str2, j, 1)
            If (ch1 = ch2) Then
            temp = 0
            Else
                temp = 1
            End If
            d(i, j) = min(d(i - 1, j) + 1, d(i, j - 1) + 1, d(i - 1, j - 1) + temp)
        Next j
    Next i
    ld = d(n, m)
End Function

Public Function sim(str1 As String, str2 As String)
    Dim ldint As Integer
    ldint = ld(str1, str2)
    Dim strlen As Integer
    If (Len(str1) >= Len(str2)) Then
        strlen = Len(str1)
    Else
        strlen = Len(str2)
    End If
    sim = 1 - ldint / strlen
End Function

zhihaizhiai

因为字符 存在唯一性，所以：
自己修正了一下内循环
增加了
exit for找到满足条件的就退出循环。



For ii = 1 To 11285   '语句循环
bb = Cells(ii, 1)

If aa = bb Then

Cells(iiii, 15) = Cells(ii, 3)
Cells(iiii, 16) = Cells(ii, 4)
Cells(iiii, 17) = Cells(ii, 6)
exit for
ElseIf sim(aa, bb) > 0.7 Then

Cells(iiii, 19) = Cells(ii, 3)
Cells(iiii, 20) = Cells(ii, 4)
Cells(iiii, 21) = Cells(ii, 6)
Cells(iiii, 22) = Cells(ii, 1)
exit for
Else


End If

Next ii