Try the following subroutine & function. It finds the closest match within a
range of cells to the value in one particular cell. It returns (via MsgBox)
the address of the cell which is the closest match (or exact match, if it
finds one.)
Sub ClosestMatch()
Dim msg1 As String, R1 As Range, R2 As Range
Dim Closest As Range, EquivPct As Double
Dim CurrRecPct As Double
On Error GoTo CMerr1
EquivPct# = 0
'R1 is cell with text to match
Set R1 = Range("A1")
'R2 is current cell in selected range to search
Range("B5:M50").Select
For Each R2 In Selection
If R1.Value = R2.Value Then
MsgBox "Found exact match in cell " _
& R2.Address
GoTo Cleanup1
End If
CurrRecPct# = Equivalence(R1, R2)
If CurrRecPct# > EquivPct# Then
EquivPct# = CurrRecPct#
Set Closest = R2
End If
Next R2
MsgBox "Closest match was cell " & _
Closest.Address
Cleanup1:
Set R1 = Nothing
Set Closest = Nothing
Exit Sub
CMerr1:
If Err.Number <> 0 Then
msg1$ = "Error # " & Str(Err.Number) & _
" was generated by " & Err.Source & _
Chr(13) & Err.Description
MsgBox msg1$, , "ClosestMatch", _
Err.HelpFile, Err.HelpContext
End If
GoTo Cleanup1
End Sub
Public Function Equivalence(Rng1 As Range, _
rng2 As Range) As Double
Dim MtchTbl(100, 100)
Dim MyMax As Double, ThisMax As Double
Dim i As Integer, j As Integer
Dim ii As Integer, jj As Integer
Dim st1 As String, st2 As String
If (Rng1.Count > 1) Or (rng2.Count > 1) Then
MsgBox "Arguments for Equivalence function " & _
"must be individual cells", vbExclamation, _
"Equivalence error"
Equivalence = -1
End If
st1$ = Trim(LCase(Rng1.Value))
st2$ = Trim(LCase(rng2.Value))
MyMax# = 0
For i% = Len(st1$) To 1 Step -1
For j% = Len(st2$) To 1 Step -1
If Mid(st1$, i%, 1) = Mid(st2$, j%, 1) Then
ThisMax# = 0
For ii% = (i% + 1) To Len(st1$)
For jj% = (j% + 1) To Len(st2$)
If MtchTbl(ii%, jj%) > ThisMax# Then
ThisMax# = MtchTbl(ii%, jj%)
End If
Next jj%
Next ii%
MtchTbl(i%, j%) = ThisMax# + 1
If (ThisMax# + 1) > ThisMax# Then
MyMax# = ThisMax# + 1
End If
End If
Next j%
Next i%
Equivalence# = MyMax# / ((Len(st1$) + Len(st2$)) / 2)
End Function
Hope this helps,
Hutch