Custom Fuzzy Lookup (in rows)

MrMaker

New Member
Joined
Jun 7, 2018
Messages
44
Hi all,

I have inherited some fuzzy match code (below) which compares two text strings, it works fine and gives me the character similarity I need, but it also gives me 5 columns of other data (which I don't want or need). Example below.

Would anyone know which bit of the below to edit out so that I just get my similarity match answer only?

VBA Code:
'UDF
  Function CustomFuzzy(rng1 As Range, rng2 As Range) As Variant   '(rng1= single value, rng2=comparisons range)

      Dim sRng As Range
      Dim fArr(1 To 6)
      tcount = rng2.Cells.Count
      ReDim tArr(1 To tcount, 1 To 2)
    
      i = 0
      For Each sRng In rng2 '  = 1 To tcount 'Each tRng In rng2
  
        i = i + 1
        tArr(i, 2) = sRng.Value
        tArr(i, 1) = Levenshtein(rng1.Value, sRng.Value)
      Next
      
     If tcount > 1 Then tArr = BubbleSrt(tArr, True)
      
     If tcount > 3 Then retValCount = 3 Else retValCount = tcount
      
     'returns the top three matches in a HORIZONTAL array
     For p = 1 To retValCount '3
        fArr((2 * p) - 1) = tArr(p, 1) 'numeric fuzzy score
        fArr((2 * p)) = tArr(p, 2) 'text
     Next p
  
     CustomFuzzy = fArr
 
  End Function
 
  'Option Base 0 assumed

  'POB: fn with byte array is 17 times faster
  Function Levenshtein(ByVal string1 As String, ByVal string2 As String) As Long

  Dim i As Long, j As Long, bs1() As Byte, bs2() As Byte
  Dim string1_length As Long
  Dim string2_length As Long
  Dim distance() As Long
  Dim min1 As Long, min2 As Long, min3 As Long

  string1_length = Len(string1)
  string2_length = Len(string2)
  ReDim distance(string1_length, string2_length)
  bs1 = string1
  bs2 = string2

  For i = 0 To string1_length
      distance(i, 0) = i
  Next

  For j = 0 To string2_length
      distance(0, j) = j
  Next

  For i = 1 To string1_length
      For j = 1 To string2_length
          'slow way: If Mid$(string1, i, 1) = Mid$(string2, j, 1) Then
          If bs1((i - 1) * 2) = bs2((j - 1) * 2) Then   ' *2 because Unicode every 2nd byte is 0
              distance(i, j) = distance(i - 1, j - 1)
          Else
              'distance(i, j) = Application.WorksheetFunction.Min _
              (distance(i - 1, j) + 1, _
               distance(i, j - 1) + 1, _
               distance(i - 1, j - 1) + 1)
              ' spell it out, 50 times faster than worksheetfunction.min
              min1 = distance(i - 1, j) + 1
              min2 = distance(i, j - 1) + 1
              min3 = distance(i - 1, j - 1) + 1
              If min1 <= min2 And min1 <= min3 Then
                  distance(i, j) = min1
              ElseIf min2 <= min1 And min2 <= min3 Then
                  distance(i, j) = min2
              Else
                  distance(i, j) = min3
              End If

          End If
      Next
  Next

  Levenshtein = distance(string1_length, string2_length)

  End Function

Public Function BubbleSrt(ArrayIn, Ascending As Boolean) 'started as 1D, converted to 2D sort
'in 2D, the first array parameter guides the lbound/ubound. I forgot the syntax for array.index to
'make this more flexible.
'The first parameter is the one it is sorted on

Dim SrtTemp As Variant
Dim i As Long
Dim j As Long

If Ascending = True Then
    For i = LBound(ArrayIn) To UBound(ArrayIn)
         For j = i + 1 To UBound(ArrayIn)
             If ArrayIn(i, 1) > ArrayIn(j, 1) Then
                'the 2D conversion is just the second half of each line, moving the second parameter
                 SrtTemp = ArrayIn(j, 1): SrtTemp2 = ArrayIn(j, 2)
                 ArrayIn(j, 1) = ArrayIn(i, 1): ArrayIn(j, 2) = ArrayIn(i, 2)
                 ArrayIn(i, 1) = SrtTemp: ArrayIn(i, 2) = SrtTemp2
             End If
         Next j
     Next i
Else
    For i = LBound(ArrayIn) To UBound(ArrayIn)
         For j = i + 1 To UBound(ArrayIn)
             If ArrayIn(i, 1) < ArrayIn(j, 1) Then
                'the 2D conversion is just the second half of each line, moving the second parameter
                 SrtTemp = ArrayIn(j, 1): SrtTemp2 = ArrayIn(j, 2)
                 ArrayIn(j, 1) = ArrayIn(i, 1): ArrayIn(j, 2) = ArrayIn(i, 2)
                 ArrayIn(i, 1) = SrtTemp: ArrayIn(i, 2) = SrtTemp2
             End If
         Next j
     Next i
End If

BubbleSrt = ArrayIn

End Function

1633419934445.png


Thanks
 

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.

Forum statistics

Threads
1,147,559
Messages
5,741,817
Members
423,689
Latest member
Jords998

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top