我在这里查看了一些问题，虽然有很多关于使用instr函数匹配类似字符串的东西，但没有太多关于完全匹配的内容。
我循环遍历按id分类的名称列表，其中每个id都有自己的相应基准。不幸的是，所有基准名称都与“巴克莱”x指数类似，其中有大量类似的声音名称，如巴克莱美国综合指数，巴克莱中间指数综合指数等......只是尝试匹配给出了输出。但是错误的数据点。这是我的参考代码..问题出现在循环的第二个elseif中。
我想知道是否有一种简单的方法可以解决这个问题。
For i = 1 To lastrow
Sheets(source).Activate
If source = "Historical" Then
If Range("A" & i).Value = delimit2 Then
benchmark_name = Sheets(source).Range("L" & i).Value
j = j + 10
name = Sheets(source).Range("A" & i + 1).Value
Sheets(output_sht).Range("D" & j - 3) = "Portfolio"
Sheets(output_sht).Range("E" & j - 3) = benchmark_name
ElseIf benchmark_name <> vbNullString _
And Range("A" & i).Value = benchmark_name Then
If IsNumeric(Sheets(source).Range("F" & i).Value) Then
Alt_return3 = Sheets(source).Range("F" & i).Value
If IsEmpty(Sheets(output_sht).Cells(j, col1)) Then
Sheets(output_sht).Cells(j, col1) = Alt_return3 / 100
End If
End If
If IsNumeric(Sheets(source).Range("G" & i).Value) Then
Alt_return5 = Sheets(source).Range("G" & i).Value
If IsEmpty(Sheets(output_sht).Cells(j + 1, col1)) Then
Sheets(output_sht).Cells(j + 1, col1) = Alt_return5 / 100
End If
End If
'
If IsNumeric(Sheets(source).Range("H" & i).Value) Then
Alt_returnINC = Sheets(source).Range("H" & i).Value
If IsEmpty(Sheets(output_sht).Cells(j + 2, col1)) Then
Sheets(output_sht).Cells(j + 2, col1) = Alt_returnINC / 100
End If
Sheets(output_sht).Range("D" & j & ":E" & j + 5).NumberFormat = "0.00%"
End If
Sheets(output_sht).Range("C" & j) = period
Sheets(output_sht).Range("C" & j + 1) = period2
Sheets(output_sht).Range("C" & j + 2) = period3
Else
End If
End If
Next i
答案 0 :(得分：0)
我知道你正在寻找完全匹配。但是，您可能需要考虑尝试使用FuzzyMatch。
http://code.google.com/p/fast-vba-fuzzy-scoring-algorithm/source/browse/trunk/Fuzzy1
您可以将此功能下载/导入到工作簿中，然后使用您要比较的2个字符串/名称调用它，它将返回一个分数。
如果我是你，我会循环浏览所有可能的名字并获得最高分。 如果您正在寻找完全匹配，那么在您的情况下将是100％。
这会为您的程序增加时间，但它可能会对您有所帮助。
=== EDITED
=========这是代码。将其添加到您的模块。
Option Explicit
Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
'To be placed in the Declarations area
'_____________________________________
Sub TestFuzzy()
Dim t As Long, a As Long, i As Long
t = GetTickCount
For i = 1 To 100000
a = Fuzzy("Sorin Sion", "Open Source")
Next
Debug.Print "Similarity score: " & a & "; " & i - 1 & " iterations took " & _
GetTickCount - t & " milliseconds"
End Sub
'TestFuzzy's result should look like:
'Similarity score: 0.3; 100000 iterations took 2094 milliseconds
'The test was done on an Intel processor at 3.2GHz
'_____________________________________
Public Function Fuzzy(ByVal s1 As String, ByVal s2 As String) As Single
Dim i As Integer, j As Integer, k As Integer, d1 As Integer, d2 As Integer, p As Integer
Dim c As String, a1 As String, a2 As String, f As Single, o As Single, w As Single
'
' ******* INPUT STRINGS CLEANSING *******
'
s1 = UCase(s1) 'input strings are converted to uppercase
d1 = Len(s1)
j = 1
For i = 1 To d1
c = Mid(s1, i, 1)
Select Case c
Case "0" To "9", "A" To "Z" 'filter the allowable characters
a1 = a1 & c 'a1 is what remains from s1 after filtering
j = j + 1
End Select
Next
If j = 1 Then Exit Function 'if s1 is empty after filtering
d1 = j - 1
s2 = UCase(s2)
d2 = Len(s2)
j = 1
For i = 1 To d2
c = Mid(s2, i, 1)
Select Case c
Case "0" To "9", "A" To "Z"
a2 = a2 & c
j = j + 1
End Select
Next
If j = 1 Then Exit Function
d2 = j - 1
k = d1
If d2 < d1 Then
'to prevent doubling the code below s1 must be made the shortest string,
'so we swap the variables
k = d2
d2 = d1
d1 = k
s1 = a2
s2 = a1
a1 = s1
a2 = s2
Else
s1 = a1
s2 = a2
End If
If k = 1 Then 'degenerate case, where the shortest string is just one character
If InStr(1, s2, s1, vbBinaryCompare) > 0 Then
Fuzzy = 1 / d2
Else
Fuzzy = 0
End If
Else '******* MAIN LOGIC HERE *******
i = 1
f = 0
o = 0
Do 'count the identical characters in s1 and s2 ("frequency analysis")
p = InStr(1, s2, Mid(s1, i, 1), vbBinaryCompare)
'search the character at position i from s1 in s2
If p > 0 Then 'found a matching character, at position p in s2
f = f + 1 'increment the frequency counter
s2 = Left(s2, p - 1) & "~" & Mid(s2, p + 1)
'replace the found character with one outside the allowable list
'(I used tilde here), to prevent re-finding
Do 'check the order of characters
If i >= k Then Exit Do 'no more characters to search
If Mid(s2, p + 1, 1) = Mid(s1, i + 1, 1) Then
'test if the next character is the same in the two strings
f = f + 1 'increment the frequency counter
o = o + 1 'increment the order counter
i = i + 1
p = p + 1
Else
Exit Do
End If
Loop
End If
If i >= k Then Exit Do
i = i + 1
Loop
If o > 0 Then o = o + 1 'if we got at least one match, adjust the order counter
'because two characters are required to define "order"
finish:
w = 2 'Weight of characters order match against characters frequency match;
'feel free to experiment, to get best matching results with your data.
'If only frequency is important, you can get rid of the second Do...Loop
'to significantly accelerate the code.
'By altering a bit the code above and the equation below you may get rid
'of the frequency parameter, since the order counter increments only for
'identical characters which are in the same order.
'However, I usually keep both parameters, since they offer maximum flexibility
'with a variety of data, and both should be maintained for this project
Fuzzy = (w * o + f) / (w + 1) / d2
End If
End Function
==================
所以，一旦你拥有它，那么只需添加这样的东西。
Dim strA, strB, hiScore(1 to 3), tempScore
With Thisworkbook.ActiveSheet
For a = 1 to .Usedrange.Rows.Count ' Scans Column 1
strA = .cells(a,1) ' Barclays Aggregate Index
For b = 1 to .usedrange.rows.count ' Compares Col 1 to Col 2
strB = .cells(b,2) ' Barclays Aggregate Other Index
tempScore = Fuzzy(strA, strB)
If tempScore > hiScore then
hiScore(1) = tempScore
hiScore(2) = a
hiScore(3) = b
End If
Next b
' Do your Action with the Best Match Here
If hiScore(1) = 1 then ' (100% - perfect match)
' Copies col 3 from the row that the best strB match was on
' to col 4 from the row strA was on
.Cells(a,4) = .Cells(hiScore(3),3)
End If
' ====
' Reset Variables
hiScore = ""
tempScore = ""
Next a
End with
答案 1 :(得分：0)