Custom Fuzzy Lookup (in rows)

[MrMaker]

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?

'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

Thanks

 

[MrMaker]

Fixed now!