Hi All,
I would appreciate greatly if any vba expert could help me with this
solutioning urgently as my deadline is drawing near (today) and i could not
resolve this solution for cell comparison.
I have a vba function code below written in such a way that it compares a
cell in Column A versus another cell in Column B. But both cells must be the
same row in order to compare. Say cell A2 contains "M O E" and cell B2
contains "Ministry of Education" and my function in cell C2 which is =
Fuzzy(A2,B2), will give me 100% correct percentages. The other example is
where A2 contains "3M" and cell B2 contains "3M Korea" and also returns 100%.
I needs someone to advice me how there is any way i could re-code my
solution such that if "3M" is in any cell in Column A say A150 and "3M Korea"
is in say cell B55 under column B. End results is both cell A150 and B55
matches by means of colored cell as it is 100% correct. Also it must not case
sensitive during matching.
Thanks in advance...
Below is my old code:
Dim TopMatch As Integer
Dim strCompare As String
Function Fuzzy(strIn1 As String, strIn2 As String) As Single
Dim L1 As Integer
Dim In1Mask(1 To 24) As Long 'strIn1 is 24 characters max
Dim iCh As Integer
Dim N As Long
Dim strTry As String
Dim strTest As String
TopMatch = 0
L1 = Len(strIn1)
strTest = UCase(strIn1)
strCompare = UCase(strIn2)
For iCh = 1 To L1
In1Mask(iCh) = 2 ^ iCh
Next iCh
'Loop thru all ordered combinations of characters in strIn1
For N = 2 ^ (L1 + 1) - 1 To 1 Step -1
strTry = ""
For iCh = 1 To L1
If In1Mask(iCh) And N Then
strTry = strTry & Mid(strTest, iCh, 1)
End If
Next iCh
If Len(strTry) > TopMatch Then TestString strTry
Next N
Fuzzy = TopMatch / CSng(L1)
End Function
Sub TestString(strIn As String)
Dim L As Integer
Dim strTry As String
Dim iCh As Integer
L = Len(strIn)
If L <= TopMatch Then Exit Sub
strTry = "*"
For iCh = 1 To L
strTry = strTry & Mid(strIn, iCh, 1) & "*"
Next iCh
If strCompare Like strTry Then
If L > TopMatch Then TopMatch = L
End If
End Sub
|
Similar Threads
