Modify DGET Function

[GabKPK]

I need to write a UDF to simulate DGET so that the function will return a string with all the records matched the criteria. For example:

=DGETModified(Database,"Name",Criteria)
The result will be a cell with value, "Name1, Name2, Name3"
Name1, Name2, and Name3 are extracted from different records that matched the criteria. I tried to use Find method in the UDF, but it doesn't work.

Pleaes help.

 

[SkipVought]

Your function could be written with slightly different requirements...

=FindAll(FindString, LookupRange, Offset)

where FindString is a value, LookupRange is a single column range of cells and Offset is the column offset where the result values will come from.

Could be written like this

Function FindAll(sValue, rngLookup As Range, off As Integer)
    Dim sOut As String
    Lookup = Application.Match(sValue, rngLookup, 0)
    If IsError(Lookup) Then
        FindAll = Empty
    Else
        sOut = rngLookup(Lookup, 1).offset(0, off).Value
        Lookup = Lookup + 1
        Do While (rngLookup(Lookup, 1) = sValue)
            sOut = sOut & ", " & rngLookup(Lookup, 1).offset(0, off).Value
            Lookup = Lookup + 1
        Loop
    End If
    FindAll = sOut
End Function

Hope this helps ;-) Skip,
metzgsk@voughtaircraft.com

 

[GabKPK]

Thanks for the codes. I have modify it so that it can have findall(database as range, outputfield as string, criteria as range) format.

Function FindAll(database As Range, outputstring As String, criteria As Range)
Dim sOut As String
Dim rnglookup As Range
Dim counter, inputfield, outputfield As Integer

inputfield = Application.Match(criteria(1, 1).Value, database.Resize(1), 0)
outputfield = Application.Match(outputstring, database.Resize(1), 0)

Set rnglookup = database.Resize(database.Rows.count - 1, 1)
Set rnglookup = rnglookup.Offset(1, inputfield - 1)
counter = 1
lookup = Application.Match(criteria(2, 1), rnglookup, 0)

If IsError(lookup) Then
FindAll = Empty
Else
If check(database, rnglookup, criteria, lookup, inputfield) Then
sOut = counter & ", " & rnglookup(lookup, 1).Offset(0, outputfield - inputfield).Value & Chr(10)
counter = counter + 1
End If
lookup = lookup + 1
Do While (lookup < rnglookup.Rows.count + 1) And rnglookup(lookup, 1) = criteria(2, 1)
If check(database, rnglookup, criteria, lookup, inputfield) Then
sOut = sOut & counter & &quot;, &quot; & rnglookup(lookup, 1).Offset(0, outputfield - inputfield).Value & Chr(10)
counter = counter + 1
End If
lookup = lookup + 1
Loop
End If
FindAll = sOut
End Function

Function check(database As Range, rnglookup As Range, criteria As Range, lookup, inputfield) As Boolean
Dim numcol, loop1, currentcol As Integer
numcol = criteria.Columns.count
For loop1 = 2 To numcol
currentcol = Application.Match(criteria(1, loop1), database.Resize(1), 0)
If rnglookup(lookup, 1).Offset(0, currentcol - inputfield).Value <> criteria(2, loop1).Value Then
check = False
Exit Function
End If
Next
check = True
End Function