私はあなたが完全な一致を探していることを知っています. ただし、FuzzyMatch を試すことを検討してください。
http://code.google.com/p/fast-vba-fuzzy-scoring-algorithm/source/browse/trunk/Fuzzy1
この関数をワークブックにダウンロード/インポートしてから、比較している 2 つの文字列/名前で呼び出すと、スコアが返されます。
私があなたなら、考えられるすべての名前をループして、最高のスコアを取得します。完全一致を探している場合、あなたの場合は100％になります。
これにより、手順に時間がかかりますが、役立つ場合があります。
===編集済み
========= これがコードです。これをモジュールに追加します。
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