excel vba validation user-defined-functions

Dynamic Data Validation

I was wondering if anyone has a better idea of how to return a tag's properties, than the UDF method shown below. Tags are listed in Column B and the properties in Column C. The code below works but is a bit slow.

After being called from a cell intercept sub - It filters through about 5000 rows, looking for a specific tag (Variable) - which comes from a data validation list.

If no matching tags were found, a notification message is returned in the cell to the right of the tag.
If a single tag entry was found, the tag's property is returned in the cell to the right of the tag.
If more than one tag entry was found, then the entries are "listed" and added to a data validation list - so the user can choose the correct option.

Option Explicit

Function DDDDL(Variable)

Dim Find As String, List As String
Dim QTY As Integer, Row As Integer
Dim lastrow As Long
Dim Rng As Range, Cell As Range

lastrow = Sheets("Tags").Range("B" & Rows.Count).End(xlUp).Row
QTY = Application.WorksheetFunction.CountIf(Sheets("Tags").Range("B3:B" & lastrow), Variable)

    If QTY = 0 Then
            Application.ThisCell.Validation.Delete
            DDDDL = "Tag not found"
                    
        ElseIf QTY = 1 Then
            Application.ThisCell.Validation.Delete
            DDDDL = Application.VLookup(Variable, Sheets("Tags").Range("B3:C" & lastrow), 2, False)
        
        ElseIf QTY > 1 Then
            DDDDL = "Pick From List"
                Set Rng = Sheets("Tags").Range("B3:B" & lastrow)
                        For Each Cell In Rng
                        If Cell = Variable Then
                            List = List & ", " & Sheets("Tags").Range("C" & Cell.Row)
                            Else
                        End If
                    Next Cell
                With Application.ThisCell.Validation
                        .Delete
                        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertWarning, Operator:=xlBetween, Formula1:=List
                        .InCellDropdown = True
                        .ErrorTitle = "TAG Description NOT found"
                        .ErrorMessage = "This TAG Description was not found in the TAG Database." & vbCrLf & "Click YES to continue, but remember to register the TAG."
                End With
    End If
End Function

I thought of creating the filtered tag list when importing the tags into the sheet - instead of each time a cell in an intercept range is changed - but I'm not sure if that will speed things up significantly since you still have to setup the data validation on the spot based on what Variable has been set.

There are about 3000 Tags ...

Solution

Public Function DDDDL(Variable) As Variant
   Dim List As String, pos As Long, lastpos As Long, lastrow As Long, tagsRng As Range, ws As Worksheet
   'CHANGE THIS ACCORDING TO REGIONAL SETTINGS
   Const ListSep = ","
   
   Set ws = Application.ThisCell.Worksheet
   lastrow = ws.Range("B" & Rows.Count).End(xlUp).Row
   Set tagsRng = ws.Range("B3:B" & lastrow)
   
   Err.Clear
   On Error Resume Next
   pos = Application.WorksheetFunction.Match(Variable, tagsRng, 0)
   If Err.Number > 0 Then  'DIDN'T FIND ANYTHING
      Application.ThisCell.Validation.Delete
      DDDDL = "Tag not found"
      GoTo Lexit
   End If
   lastpos = pos
   pos = Application.WorksheetFunction.Match(Variable, tagsRng.Offset(lastpos, 0), 0)
   If Err.Number > 0 Then  'WE FOUND ONE (the previus match)
      Application.ThisCell.Validation.Delete
      DDDDL = tagsRng.Cells(lastpos, 1).Offset(0, 1).Value2
      GoTo Lexit
   End If
   '---------we found two-------add in list-----
   List = tagsRng.Cells(lastpos, 1).Offset(0, 1).Value2 & ListSep & tagsRng.Cells(pos + lastpos, 1).Offset(0, 1).Value2
   lastpos = lastpos + pos
   
   'loop for more matches
   Do
      pos = Application.WorksheetFunction.Match(Variable, tagsRng.Offset(lastpos, 0), 0)
      If Err.Number > 0 Then 'no more
         Err.Clear
         Exit Do
      Else        'add founded in list
         List = List & ListSep & tagsRng.Cells(pos + lastpos, 1).Offset(0, 1).Value2
         lastpos = lastpos + pos 'next time search using as offset => lastpos
      End If
   Loop
   On Error GoTo 0
   With Application.ThisCell.Validation
      .Delete
      .Add Type:=xlValidateList, AlertStyle:=xlValidAlertWarning, Operator:=xlBetween, Formula1:=List   'AlertStyle:=xlValidAlertWarning
      .InCellDropdown = True
      .ErrorTitle = "TAG Description NOT found"
      .ErrorMessage = "This TAG Description was not found in the TAG Database." & vbCrLf & "Click YES to continue, but remember to register the TAG."
   End With
   DDDDL = "Pick From List"
   Exit Function
Lexit:
   On Error GoTo 0
End Function

Another version of the same code, which can be called in two ways: 1) by using it as a formula in a cell, or 2) from VBA code and returning a string (listItems). I also set several Optional parameters (with default values that the question requires) to make it more flexible to use

Option Explicit

Public Function DDDDL(Variable As String, _
                      Optional ws As Worksheet = Nothing, _
                      Optional saearchFromRow As Long = 3, _
                      Optional searchColLetter As String = "B", _
                      Optional lookAtRowOffset As Long = 0, _
                      Optional lookAtColOffset As Long = 1) As Variant
                      
   Dim listItems As String, callFromCell As Boolean, pos As Long, lastPos As Long
   Dim lastRow As Long, tagsRng As Range, targetCell As Range
   Const listSep = ";"
   
   callFromCell = TypeName(Application.Caller) = "Range"
   If callFromCell Then
      Set targetCell = Application.ThisCell
      Set ws = targetCell.Worksheet
   Else
      If ws Is Nothing Then Exit Function
   End If
   
   Set tagsRng = ws.Range(searchColLetter & Rows.Count).End(xlUp)
   lastRow = ws.Range(searchColLetter & Rows.Count).End(xlUp).Row
   Set tagsRng = ws.Range(searchColLetter & saearchFromRow & ":" & searchColLetter & lastRow)
   
   Err.Clear
   On Error Resume Next
   pos = Application.WorksheetFunction.Match(Variable, tagsRng, 0)
   If Err.Number > 0 Then  'DIDN'T FIND ANYTHING
      If callFromCell Then
         targetCell.Validation.Delete
         DDDDL = "Tag not found"
      End If
      GoTo Lexit
   End If
   lastPos = pos
   pos = Application.WorksheetFunction.Match(Variable, tagsRng.Offset(lastPos, 0), 0)
   If Err.Number > 0 Then  'WE FOUND ONE (the previus match)
      If callFromCell Then
         targetCell.Validation.Delete
      End If
      DDDDL = tagsRng(lastPos, 1).Offset(lookAtRowOffset, lookAtColOffset).Value2
      GoTo Lexit
   End If
   '---------we found two-------add in listItems-----
   listItems = tagsRng(lastPos, 1).Offset(lookAtRowOffset, lookAtColOffset).Value2 & listSep & _
          tagsRng(pos + lastPos, 1).Offset(lookAtRowOffset, lookAtColOffset).Value2
   lastPos = lastPos + pos
   
   'loop for more matches
   Do
      pos = Application.WorksheetFunction.Match(Variable, tagsRng.Offset(lastPos, 0), 0)
      If Err.Number > 0 Then 'no more
         Err.Clear
         Exit Do
      Else        'add founded in listItems
         listItems = listItems & listSep & tagsRng(pos + lastPos, 1).Offset(lookAtRowOffset, lookAtColOffset).Value2
         lastPos = lastPos + pos 'next time search using as offset => lastPos
      End If
   Loop
   On Error GoTo 0
   If callFromCell Then
      With targetCell.Validation
         .Delete
         .Add Type:=xlValidateList, AlertStyle:=xlValidAlertWarning, Operator:=xlBetween, Formula1:=listItems
         .InCellDropdown = True
         .ErrorTitle = "TAG Description NOT found"
         .ErrorMessage = "" '"This TAG Description was not found in the TAG Database." & vbCrLf & "Click YES to continue, but remember to register the TAG."
      End With
      DDDDL = "Pick From listItems"
   Else
      DDDDL = listItems
   End If
Lexit:
   On Error GoTo 0
End Function

Sub usageExample()
   Debug.Print DDDDL("CCC", SHEET16)   '
   Debug.Print DDDDL("ZZZ", Worksheets("MySheet"))
End Sub