Excel VBA User-Defined Function to query an Access Database

问题

I have an Access 365 database that has Invoice Numbers, Due Dates, and Amounts Due. I'm trying to create an Excel UDF, whereby I input the Due Date and Invoice Number, and the function queries the database and returns the Amount Due.

The formula result is #Value and there's no compiler error, though there appears to be an error when it attempts to open the record set (I set up a error message box for this action). Perhaps there's an issue with my SQL? I'd appreciate any assistance with this matter.

I've found several discussions of similar topic, but I've been unable to get this code to work. I'd appreciate any assistance with this matter.

https://www.mrexcel.com/board/threads/need-help-creating-user-defined-functions-in-excel-to-query-from-a-database.943894/

Here's the code:

Function CLLData(inpDate As Long, inpInvoiceNum As String)
    
    Dim conn As Object
    Dim rs As Object
    Dim AccessFilePath As String
    Dim SqlQuery As String
    Dim sConnect As String
     
    'Disable screen flickering.
    Application.ScreenUpdating = False
    
    'Specify the file path of the accdb file.
    AccessFilePath = ThisWorkbook.Path & "\" & "CRDD.accdb"
       
    'Create the connection string.
    sConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessFilePath
    
    On Error Resume Next
    'Create the Connection object.
    Set conn = CreateObject("ADODB.Connection")
    'Check if the object was created.
    If Err.Number <> 0 Then
        MsgBox "Connection was not created!", vbCritical, "Connection Error"
        'Exit Sub
    End If
    On Error GoTo 0
        
        
    On Error Resume Next
    'Open the connection.
    conn.Open sConnect
    'Check if the object was created.
    If Err.Number <> 0 Then
        MsgBox "Connection was not opened!", vbCritical, "Connection Open Error"
        'Exit Sub
    End If
    On Error GoTo 0

    'SQL statement to retrieve the data from the table.
    SqlQuery = "SELECT [Value] FROM tblRawCallData WHERE (([DueDate] = '" & inpDate & "') AND ([Invoice] = '" & inpInvoiceNum & "'));"
    
    On Error Resume Next
    'Create the ADODB recordset object
    Set rs = CreateObject("ADODB.Recordset")
    'Check if the object was created.
    If Err.Number <> 0 Then
        Set rs = Nothing
        Set conn = Nothing
        MsgBox "Recordset was not created!", vbCritical, "Recordset Error"
        'Exit Sub
    End If
    On Error GoTo 0
        
    On Error Resume Next
    'Open the recordset.
    rs.Open SqlQuery, conn
    'Check if the recordset was opened.
    If Err.Number <> 0 Then
        Set rs = Nothing
        Set conn = Nothing
        MsgBox "Recordset was not opened!", vbCritical, "Recordset open error"
        'Exit Sub
    End If
    On Error GoTo 0
    
    ' Check there is data.
    If Not rs.EOF Then
        ' Transfer result.
        CLLData = rs!Value
        MsgBox "Records: ", vbCritical, "Records"
        ' Close the recordset
    Else
        'Not found; return #N/A! error
        CLLData = CVErr(xlErrNA)
        MsgBox "No records in recordset!", vbCritical, "No Records"
    End If
    rs.Close
    
    ' Clean up
    If CBool(conn.State And adStateOpen) Then conn.Close
    Set conn = Nothing
    Set rs = Nothing
    
    'Enable the screen.
     Application.ScreenUpdating = True
End Function

回答1:

Seems like your function could be significantly less complex.

Comment out the error handler until you get it working when called from a Sub.

Function CLLData(inpDate As Long, inpInvoiceNum As String)
    
    Dim conn As Object
    Dim rs As Object
    Dim AccessFilePath As String
    Dim SqlQuery As String
    Dim sConnect As String
    
    AccessFilePath = ThisWorkbook.path & "\" & "CRDD.accdb"
    sConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessFilePath
    
    On Error GoTo haveError
    
    Set conn = CreateObject("ADODB.Connection")
    conn.Open sConnect
   
    SqlQuery = "SELECT [Value] FROM tblRawCallData WHERE [DueDate] = " & inpDate & _
               " AND [Invoice] = '" & inpInvoiceNum & "'"
    
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open SqlQuery, conn
    If Not rs.EOF Then
        CLLData = rs.Fields("Value").Value
    Else
        CLLData = CVErr(xlErrNA)
    End If
    rs.Close
    Exit Function

haveError:
    CLLData = "Error:" & Err.Description

End Function

回答2:

You need two or three corrections, as date values always should be handled as DateTime, and your invoice number most likely is numeric:

Function CLLData(inpDate As Date, inpInvoiceNum As String)

' <snip>

'SQL statement to retrieve the data from the table.
SqlQuery = "SELECT [Value] FROM tblRawCallData WHERE (([DueDate] = #" & Format(inpDate, "yyyy\/mm\/dd") & "#) AND ([Invoice] = " & inpInvoiceNum & "));"

Edit for numeric "date" and alpha-numeric invoice:

SqlQuery = "SELECT [Value] FROM tblRawCallData WHERE (([DueDate] = #" & Format(inpDate, "@@@@\/@@\/@@") & "#) AND ([Invoice] = '" & inpInvoiceNum & "'));"

来源：https://stackoverflow.com/questions/63408630/excel-vba-user-defined-function-to-query-an-access-database