Replace DLookup by an equivalent select query.
-Tom.

Here are some useful functions from Allen Browne.

I always use ELookup(........) etc  Much faster and does not load the
database so much

HTH

Phil

Function EMin(expr As String, domain As String, Optional Criteria)

On Error GoTo Err_EMin
   'Purpose:   Faster and more flexible replacement for Emin()
   'Arguments: Same as Emin, with additional Order By option.
   'Return:    Value of the Expr if found, else Null or #Error.
   'Author:    Allen Browne. abrowne1@bigpond.net.au, Phil S

   Dim MyDb As Database
   Dim rs As Recordset
   Dim SQLStg As String

   'Build the SQL string.
   SQLStg = "SELECT " & expr & " FROM " & domain
   If Not IsMissing(Criteria) Then
       SQLStg = SQLStg & " WHERE " & Criteria
   End If
   SQLStg = SQLStg & " ORDER BY " & expr
   SQLStg = SQLStg & ";"

   'Lookup the value.
   Set MyDb = DBEngine(0)(0)
   Set rs = MyDb.OpenRecordset(SQLStg, dbOpenForwardOnly)
   If rs.RecordCount = 0 Then
       EMin = Null
   Else
       EMin = rs(0)
   End If
   rs.Close

Exit_EMin:
   Set rs = Nothing
   Set MyDb = Nothing
   Exit Function

Err_EMin:
'    MsgBox Err.Description, vbExclamation, "EMin Error " & Err.number
   If Err.Number < 0& Or Err.Number > 65535 Then    'Valid range for
CVErr()
       EMin = CVErr(5)                          'Out of range.
   Else
       EMin = CVErr(Err.Number)
   End If
   Resume Exit_EMin

End Function

Function EMax(expr As String, domain As String, Optional Criteria)

On Error GoTo Err_EMax
   'Purpose:   Faster and more flexible replacement for Emin()
   'Arguments: Same as Emin, with additional Order By option.
   'Return:    Value of the Expr if found, else Null or #Error.
   'Author:    Allen Browne. abrowne1@bigpond.net.au, Phil S

   Dim MyDb As Database
   Dim rs As Recordset
   Dim SQLStg As String

   'Build the SQL string.
   SQLStg = "SELECT " & expr & " FROM " & domain
   If Not IsMissing(Criteria) Then
       SQLStg = SQLStg & " WHERE " & Criteria
   End If
   SQLStg = SQLStg & " ORDER BY " & expr & " DESC"
   SQLStg = SQLStg & ";"

   'Lookup the value.
   Set MyDb = DBEngine(0)(0)
   Set rs = MyDb.OpenRecordset(SQLStg, dbOpenForwardOnly)
   If rs.RecordCount = 0 Then
       EMax = Null
   Else
       EMax = rs(0)
   End If
   rs.Close

Exit_EMax:
   Set rs = Nothing
   Set MyDb = Nothing
   Exit Function

Err_EMax:
'    MsgBox Err.Description, vbExclamation, "EMax Error " & Err.number
   If Err.Number < 0& Or Err.Number > 65535 Then    'Valid range for
CVErr()
       EMax = CVErr(5)                          'Out of range.
   Else
       EMax = CVErr(Err.Number)
   End If
   Resume Exit_EMax

End Function

Public Function ELookup(expr As String, domain As String, Optional Criteria,
Optional OrderClause)

   On Error GoTo Err_ELookup
   'Purpose:   Faster and more flexible replacement for DLookup()
   'Arguments: Same as DLookup, with additional Order By option.
   'Return:    Value of the Expr if found, else Null or #Error.
   'Author:    Allen Browne. abrowne1@bigpond.net.au
   'Examples:
   '1. To find the last value, include DESC in the OrderClause, e.g.:
   '  ELookup("[Surname] & [FirstName]", "tblClient", , "ClientID DESC")
   '2. To find the lowest non-null value of a field, use the Criteria,
   'e.g.:
   '  ELookup("ClientID", "tblClient", "Surname Is Not Null" , "Surname")
   'Note:      Requires a reference to the DAO library.
   Dim MyDb As Database
   Dim rs As Recordset
   Dim SQLStg As String

   'Build the SQL string.
   SQLStg = "SELECT TOP 1 " & expr & " FROM " & domain
   If Not IsMissing(Criteria) Then
       SQLStg = SQLStg & " WHERE " & Criteria
   End If
   If Not IsMissing(OrderClause) Then
       SQLStg = SQLStg & " ORDER BY " & OrderClause
   End If
   SQLStg = SQLStg & ";"

   'Lookup the value.
   Set MyDb = DBEngine(0)(0)
   Set rs = MyDb.OpenRecordset(SQLStg, dbOpenForwardOnly)
   If rs.RecordCount = 0 Then
       ELookup = Null
   Else
       ELookup = rs(0)
   End If
   rs.Close

Exit_ELookup:
   Set rs = Nothing
   Set MyDb = Nothing
   Exit Function

Err_ELookup:
'    MsgBox Err.Description, vbExclamation, "ELookup Error " & Err.number
   If Err.Number < 0& Or Err.Number > 65535 Then    'Valid range for
CVErr()
       ELookup = CVErr(5)                          'Out of range.
   Else
       ELookup = CVErr(Err.Number)
   End If
   Resume Exit_ELookup

End Function