VBA为首字母缩略词创build参考字典

我正在实现一个非常有用的代码来计算两列之间的相似度。 示例：第一列包含“ABC公司”，第二列包含“ABCD公司”。 VBA代码然后将返回列1和列2是99％相似。 这很好用！

我的问题/问题：现在我想添加一些识别缩写词的代码，或者将两个词作为相同的代码。 例如：如果第1栏包含“ABC有限责任公司”，第2栏包含“ABC有限责任公司”，我希望代码认识到“有限责任公司”和“有限责任公司”实际上是同一件事。 我可以在字典中定义这个，或者把这两个东西设置成彼此相等吗？ 谢谢！ 下面列出了我要添加的代码

Public Function Similarity(ByVal String1 As String, _ ByVal String2 As String, _ Optional ByRef RetMatch As String, _ Optional min_match = 1) As Single 'Returns percentile of similarity between 2 strings (ignores case) '"RetMatch" returns the characters that match(in order) '"min_match" specifies minimum number af char's in a row to match Dim b1() As Byte, b2() As Byte Dim lngLen1 As Long, lngLen2 As Long Dim lngResult As Long If UCase(String1) = UCase(String2) Then '..Exactly the same Similarity = 1 Else '..one string is empty lngLen1 = Len(String1) lngLen2 = Len(String2) If (lngLen1 = 0) Or (lngLen2 = 0) Then Similarity = 0 Else '..otherwise find similarity b1() = StrConv(UCase(String1), vbFromUnicode) b2() = StrConv(UCase(String2), vbFromUnicode) lngResult = Similarity_sub(0, lngLen1 - 1, _ 0, lngLen2 - 1, _ b1, b2, _ String1, _ RetMatch, _ min_match) Erase b1 Erase b2 If lngLen1 >= lngLen2 Then Similarity = lngResult / lngLen1 Else Similarity = lngResult / lngLen2 End If End If End If End Function Private Function Similarity_sub(ByVal start1 As Long, ByVal end1 As Long, _ ByVal start2 As Long, ByVal end2 As Long, _ ByRef b1() As Byte, ByRef b2() As Byte, _ ByVal FirstString As String, _ ByRef RetMatch As String, _ ByVal min_match As Long, _ Optional recur_level As Integer = 0) As Long '* CALLED BY: Similarity * (RECURSIVE) Dim lngCurr1 As Long, lngCurr2 As Long Dim lngMatchAt1 As Long, lngMatchAt2 As Long Dim i As Long Dim lngLongestMatch As Long, lngLocalLongestMatch As Long Dim strRetMatch1 As String, strRetMatch2 As String If (start1 > end1) Or (start1 < 0) Or (end1 - start1 + 1 < min_match) _ Or (start2 > end2) Or (start2 < 0) Or (end2 - start2 + 1 < min_match) Then Exit Function '(exit if start/end is out of string, or length is too short) End If For lngCurr1 = start1 To end1 '(for each char of first string) For lngCurr2 = start2 To end2 '(for each char of second string) i = 0 Do Until b1(lngCurr1 + i) <> b2(lngCurr2 + i) 'as long as chars DO match.. i = i + 1 If i > lngLongestMatch Then '..if longer than previous best, store starts & length lngMatchAt1 = lngCurr1 lngMatchAt2 = lngCurr2 lngLongestMatch = i End If If (lngCurr1 + i) > end1 Or (lngCurr2 + i) > end2 Then Exit Do Loop Next lngCurr2 Next lngCurr1 If lngLongestMatch < min_match Then Exit Function 'no matches at all, so no point checking for sub-matches! lngLocalLongestMatch = lngLongestMatch 'call again for BEFORE + AFTER RetMatch = "" 'Find longest match BEFORE the current position lngLongestMatch = lngLongestMatch _ + Similarity_sub(start1, lngMatchAt1 - 1, _ start2, lngMatchAt2 - 1, _ b1, b2, _ FirstString, _ strRetMatch1, _ min_match, _ recur_level + 1) If strRetMatch1 <> "" Then RetMatch = RetMatch & strRetMatch1 & "*" Else RetMatch = RetMatch & IIf(recur_level = 0 _ And lngLocalLongestMatch > 0 _ And (lngMatchAt1 > 1 Or lngMatchAt2 > 1) _ , "*", "") End If 'add local longest RetMatch = RetMatch & Mid$(FirstString, lngMatchAt1 + 1, lngLocalLongestMatch) 'Find longest match AFTER the current position lngLongestMatch = lngLongestMatch _ + Similarity_sub(lngMatchAt1 + lngLocalLongestMatch, end1, _ lngMatchAt2 + lngLocalLongestMatch, end2, _ b1, b2, _ FirstString, _ strRetMatch2, _ min_match, _ recur_level + 1`enter code here`) If strRetMatch2 <> "" Then RetMatch = RetMatch & "*" & strRetMatch2 Else RetMatch = RetMatch & IIf(recur_level = 0 _ And lngLocalLongestMatch > 0 _ And ((lngMatchAt1 + lngLocalLongestMatch < end1) _ Or (lngMatchAt2 + lngLocalLongestMatch < end2)) _ , "*", "") End If 'Return result Similarity_sub = lngLongestMatch End Function 

Answer 1

这可能是最简单的事情：

 If str = "LLC" then str.replace("LLC","Limited Liability Company") end if 

把它放在一个foreach中，用两个列表来寻找要改变的东西。 像这样的东西：

 Option Explicit Public Sub CheckMe() Dim ListA As Collection Dim ListB As Collection Dim str As String Dim strResult As String Dim varStr As Variant Dim var As Variant Dim varAdd As Variant Dim counter As Variant str = "LiLaCa is a AnAtBaa company" strResult = "" Set ListA = New Collection Set ListB = New Collection ListA.Add ("LLC") ListA.Add ("AAB") ListA.Add ("BBA") ListB.Add ("LiLaCa") ListB.Add ("AnAtBaa") ListB.Add ("BuBuAaaaaa") varStr = Split(str) For Each var In varStr varAdd = var For counter = 1 To ListB.Count If var = ListB(counter) Then varAdd = Replace(var, ListB(counter), ListA(counter)) Next counter strResult = strResult & varAdd & " " Next var Debug.Print strResult End Sub