字符串相似度算法2 （余弦相似度算法 Cosine Similarity） VBA 实现

lsdongjh

1. Sub Test()
   
2. 
   
3.     Debug.Print CosineSimilarity("http://excelhome", "http://club.excelhome") '相似度为0.9320546490018
   
4.     Debug.Print CosineSimilarity("Excel VBA程序开发", "VBA程序") '相似度为0.645497224367903
   
5.    
   
6.     '余弦相似度 以 词 为单位, 对距离不敏感，所以下面这两个例子的相似度为 100%
   
7.     Debug.Print CosineSimilarity("excelhome", "homeexcel")
   
8.     Debug.Print CosineSimilarity("生活好美", "美好生活")
   
9.    
   
10. End Sub
    
11. 
    
12. '余弦相似度算法 VBA 实现
    
13. Function CosineSimilarity(strA As String, strB As String) As Double
    
14.     Dim objDic_All As Object, objDic_1 As Object, objDic_2 As Object
    
15.     Dim lngID As Long, strKey As String
    
16.     Dim arrKey As Variant, arrResult As Variant
    
17.     Dim dblSum As Double, dblVal_A As Double, dblVal_B As Double
    
18.    
    
19.     If strA = "" Or strB = "" Then
    
20.         CosineSimilarity = 0
    
21.         Exit Function
    
22.     End If
    
23.    
    
24.     '==========================================================
    
25.     'VBA下没有合适的 分词API
    
26.     '只能分字了，太囧了
    
27.     '
    
28.     Set objDic_All = CreateObject("Scripting.Dictionary")
    
29.     Set objDic_1 = CreateObject("Scripting.Dictionary")
    
30.     Set objDic_2 = CreateObject("Scripting.Dictionary")
    
31.    
    
32.     For lngID = 1 To Len(strA)
    
33.         strKey = Trim(Mid(strA, lngID, 1))
    
34.         If strKey <> "" Then
    
35.             objDic_All(strKey) = ""
    
36.             objDic_1(strKey) = Val(objDic_1(strKey)) + 1
    
37.         End If
    
38.     Next
    
39.     For lngID = 1 To Len(strB)
    
40.         strKey = Trim(Mid(strB, lngID, 1))
    
41.         If strKey <> "" Then
    
42.             objDic_All(strKey) = ""
    
43.             objDic_2(strKey) = Val(objDic_2(strKey)) + 1
    
44.         End If
    
45.     Next
    
46.     '上面的这部分代码，如果有合适的分词工具，会更加精准
    
47.     '==========================================================
    
48.    
    
49.     arrKey = objDic_All.keys
    
50.     ReDim arrResult(LBound(arrKey) To UBound(arrKey), 1 To 3)
    
51.    
    
52.     For lngID = LBound(arrKey) To UBound(arrKey)
    
53.         arrResult(lngID, 1) = arrKey(lngID)
    
54.         arrResult(lngID, 2) = objDic_1(arrKey(lngID)) + 0
    
55.         arrResult(lngID, 3) = objDic_2(arrKey(lngID)) + 0
    
56.     Next
    
57.    
    
58.     Set objDic_All = Nothing
    
59.     Set objDic_1 = Nothing
    
60.     Set objDic_2 = Nothing
    
61.    
    
62.     For lngID = LBound(arrResult) To UBound(arrResult)
    
63.         dblSum = dblSum + arrResult(lngID, 2) * arrResult(lngID, 3)
    
64.         dblVal_A = dblVal_A + arrResult(lngID, 2) ^ 2
    
65.         dblVal_B = dblVal_B + arrResult(lngID, 3) ^ 2
    
66.     Next
    
67.    
    
68.     CosineSimilarity = dblSum / (Sqr(dblVal_A) * Sqr(dblVal_B))
    
69. End Function
    

复制代码

goldowl2011

标注一下，下载学习，很棒呀