CODEWITHSUNDEEP
excelvba
Rodger
Rodger

Reputation: 841

Custom Function Wrong Data Type - Why? Also How to debug?

I have written a custom function and am not sure how to figure out the issue. If someone knows why it is erroring out, that would be of interest for sure so that I can get it to work. But in the spirit of learning to fish I also need to know how to sort this out on my own next time. If I change it to a sub and uncomment the test variables section (and comment the function= line at the end so the sub doesn't complain about it) I use it perfectly.

If I go to the sheet and put the function into a cell with the same info as in the test section it throws a wrong data type error. I tried setting breakpoints to step through but it doesn't event get to screenupdating=false apparently.

What it does - in case it matters - I see that frequently in posts so figured I'd preempt it. Skip this part if it doesn't matter. :-) Basically it flips the vlookup around so that =InvertedVLookup(Q25:Q43,R25:V43,N25,5) looks at cell N25 as a string and then uses the list of strings in q25:q43 as part of a substring search. If it finds a match it returns the value from the 5th column where the match was. If it doesn't find a match it looks at the values in r25:v43 line by line, expanding comma delimited lines in order to find the line that has the most matches. Its for orders that don't have normalized text.

So Red Fire Truck truck001 in N25 would be looked at repeatedly by the parts list in column Q and if there is a truck001 it would return column 5(price). If not it would look through r:v for any that have truck then any that did it will look at the color and other descriptors. This way If we get Fire truck truck001 red or truck, fire, red truck001 it finds it. Likewise if we keep seeing the same abbreviation or misspelling we can comma delimit that so that red, redd would find the match while both are in the same cell. 

Public Function InvertedVLookup(Substrings_Array As Variant, Table_Array As Variant, Target_String As String, Column_Index_To_Return As Integer, Optional Approx_Match As Boolean = True)
'by [email protected]

    Application.ScreenUpdating = False

    Dim sResult
    Dim LB As Integer, UB As Integer, LB2 As Integer, UB2 As Integer, iMax As Integer
    Dim bDuplicate As Boolean
    Dim ws As Worksheet
    Dim aExpanded_Table_Array
    Set ws = ActiveSheet
    Dim aTableDelimitersExpanded()
    Dim aApproxMatch() As Integer

    '    ' =========== test variables ==== comment out when using function instead of sub ==============
    '    Dim Substrings_Array  As Variant
    '    Dim Table_Array  As Variant
    '    Dim Target_String As String
    '    Dim Column_Index_To_Return As Integer
    '    Dim Approx_Match As Boolean
    '    Substrings_Array = ws.Cells.Range("Q25:Q43")
    '    Table_Array = ws.Cells.Range("R25:V43")
    '    Target_String = ws.Cells.Range("N26").Value
    '    Column_Index_To_Return = 5
    '    Approx_Match = True
    '    ' =========== test variables ==== comment out when using function instead of sub ==============


    bDuplicate = False
    iMax = 0

        LB = LBound(Substrings_Array)
        UB = UBound(Substrings_Array)
        LB2 = LBound(Table_Array, 2)
        UB2 = UBound(Table_Array, 2)

    Dim strTemp As String
    For i = LB To UB
        If IsNull(Substrings_Array(i, 1)) = False Then
            If InStr(LCase(Target_String), LCase(Substrings_Array(i, 1))) > 0 Then
                sResult = i
                Exit For
            End If
        Else
            sResult = "Target String Null"
            GoTo ErrorHandling
        End If
    Next i

    If IsEmpty(sResult) = True Then
        If Approx_Match = True Then
            ReDim Preserve aTableDelimitersExpanded(LB To UB, LB2 To UB2)
            ReDim aApproxMatch(1 To UB, 1 To 1)
            Dim str
            Dim strSplit() As String

            'Check for and total the number of matching qualifiers
            For i = LB To UB
                For j = LBound(Table_Array, 2) To UBound(Table_Array, 2)
                    strSplit = Split(Table_Array(i, j), ", ")
                    For k = LBound(strSplit) To UBound(strSplit)
                        If IsNull(strSplit(k)) = False Then
                            If InStr(LCase(Target_String), LCase(strSplit(k))) > 0 Then
                                aApproxMatch(i, 1) = aApproxMatch(i, 1) + 1
                            End If
                        End If
                    Next k
                Next j
            Next i

            'look at aApproxMatch table for highest value to indicate best match
            For i = LB To UB
                If aApproxMatch(i, 1) > iMax Then
                    iMax = aApproxMatch(i, 1)
                    sResult = i
                    bDuplicate = False
                ElseIf aApproxMatch(i, 1) = iMax Then
                    bDuplicate = True
                End If
            Next i

            'check for ties based on qualifiers
            If bDuplicate = True Then
                sResult = "Multiple Matches"
                GoTo ErrorHandling
            End If
        Else
            sResult = "No Match"
            GoTo ErrorHandling
        End If
    End If

    'return the result
    sResult = Table_Array(sResult, Column_Index_To_Return)

ErrorHandling:
    'If sResult = "Target String Null"
    'If sResult = "No Match"
    'If sResult = "Multiple Matches"

    InvertedVLookup = sResult
    Application.ScreenUpdating = True
End Function

Upvotes: 2

Views: 156

Answers (1)

Dirk Reichel
Dirk Reichel

Reputation: 7979

this should work as wanted:

Public Function InvertedVLookup(Substrings_Array As Variant, Table_Array As Variant, Target_String As String, Column_Index_To_Return As Integer, Optional Approx_Match As Boolean = True)
  Dim sResult
  Dim Bou(2) As Long
  Dim aApproxMatch() As Integer
  Dim strSplit() As String
  Bou(0) = LBound(Substrings_Array.Value)
  Bou(1) = UBound(Substrings_Array.Value)
  For i = Bou(0) To Bou(1)
    If IsNull(Substrings_Array(i, 1)) Then
      InvertedVLookup = "Target String Null"
      Exit Function
    Else
      If InStr(LCase(Target_String), LCase(Substrings_Array(i, 1))) Then
     'If InStr(1, Target_String, Substrings_Array(i, 1), 1) Then '<~~~ better use this than LCase
        sResult = i
        Exit For
      End If
    End If
  Next i
  If IsEmpty(sResult) Then
    If Approx_Match Then
      ReDim aApproxMatch(1 To Bou(1), 1 To 1)
      For i = Bou(0) To Bou(1)
        For j = LBound(Table_Array.Value, 2) To UBound(Table_Array.Value, 2)
          strSplit = Split(Table_Array(i, j), ", ")
          For k = LBound(strSplit) To UBound(strSplit)
            If Not IsNull(strSplit(k)) Then
              If InStr(LCase(Target_String), LCase(strSplit(k))) Then
             'If InStr(1, Target_String, strSplit(k), 1) Then '<~~~ better use this than LCase
                aApproxMatch(i, 1) = aApproxMatch(i, 1) + 1
              End If
            End If
          Next k
        Next j
      Next i
      For i = Bou(0) To Bou(1)
        If aApproxMatch(i, 1) > Bou(2) Then
          Bou(2) = aApproxMatch(i, 1)
          sResult = i
        ElseIf aApproxMatch(i, 1) = Bou(2) Then
          InvertedVLookup = "Multiple Matches"
          Exit Function
        End If
      Next i
    Else
      InvertedVLookup = "No Match"
      Exit Function
    End If
  End If
  InvertedVLookup = Table_Array(sResult, Column_Index_To_Return)
End Function

Skipped a lot of obsolete code...

Upvotes: 2

Related Questions