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

Presuming that what you're after is a way to apply CF with a measure of fuzzy
matching, here's something which might work (it uses Ron Rosenfeld's FrstLtrs
UDF) ..

Illustrated in this sample:
http://www.flypicture.com/download/ODk3OQ==
Fuzzy Match n Conditional Formatting.xls

Assume source data within A2:A200 (eg M O E, 3M, M O M, etc), with data to
be conditionally formatted in B2 down (eg Ministry of Education, 3M Korea,
Ministry of Manpower, etc) based on fuzzy matching with source data in col A

Select col B, then apply conditional format using Formula is:

Condition 1:
=SUMPRODUCT(ISNUMBER(SEARCH(A$2:A$200,B1))*(A$2:A$ 200<""))0
Format: Red fill/white font,bolded

Condition 2:
=AND(B1<"",SUMPRODUCT((ISNUMBER(SEARCH(FrstLtrs(B 1),SUBSTITUTE(A$2:A$200,"
",""))))*(A$2:A$200<""))0)
Format: Dark Blue fill/white font,bolded

The above requires Ron Rosenfeld's FrstLtrs UDF (below) to be pre-installed:

'===========
Function FrstLtrs(str As String) As String
' Ron Rosenfeld

Dim temp
Dim i As Long

temp = Split(Trim(str))
For i = 0 To UBound(temp)
FrstLtrs = FrstLtrs & Left(temp(i), 1)
Next i
--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---
"Tan" wrote:
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

Apologies, the earlier paste of Ron's UDF was incomplete. Here's the
complete paste:

'===========
Function FrstLtrs(str As String) As String
' Ron Rosenfeld

Dim temp
Dim i As Long


temp = Split(Trim(str))


For i = 0 To UBound(temp)
FrstLtrs = FrstLtrs & Left(temp(i), 1)
Next i


End Function
'============

--
Max
Singapore
http://savefile.com/projects/236895
xdemechanik
---