Excel VBA function with Recordset (Performance issue)

问题

I have a database in SQL Server that I'm using to feed some financial reports in Excel. I'm using Recordsets through a custom Excel Function that uses arguments from Cells to build the SQL queries. Here is how the code looks:

 Public Function Test(arg1 As String, arg2 As String, arg3 As Integer, arg4 As Integer, arg5 As String) As Variant
    Dim oConnection As ADODB.Connection
    Set oConnection = New ADODB.Connection
    Dim oRecordset As ADODB.Recordset
    Set oRecordset = New ADODB.Recordset

    Dim strSQL As String

    strSQL = "SELECT SUM(BALANCE) as Total FROM Accounting WHERE ARGUMENT1 = " & Chr$(39) & arg1 & Chr$(39) & " AND ARGUMENT2 = " & Chr$(39) & arg2 & Chr$(39) & " AND ARGUMENT3 = " & Chr$(39) & arg3 & Chr$(39) & " AND ARGUMENT4 = " & arg4 & "  AND ARGUMENT5 = " & arg5 & ""

    oConnection.Open "Provider=SQLOLEDB;" & _
                         "Data Source=(IP of database);" & _
                         "Initial Catalog=(catalog of database);" & _
                         "Trusted_connection=yes;"

    oRecordset.Open Source:=strSQL, ActiveConnection:=oConnection, CursorType:=adOpenForwardOnly, LockType:=adLockReadOnly, Options:=adCmdText


    Test = oRecordset!Total

        oRecordset.Close
        Set oRecordset = Nothing


End Function

So, this code works very well but I'm having a performance issue. I have to fill dozens of cells, and each cell uses different arguments coming from different cells. So I have reports that take over 1 minute to load fully.

I'm using adOpenForwardOnly, but are there any other fine tunings I can do to the code to speed up things?

Thank you very much

回答1:

If your data is not particularly time-sensitive then you can "memoize" your UDF by having it cache previously-queried results using a dictionary object.

Untested:

Public Function Test(arg1 As String, arg2 As String, arg3 As Integer, _
                            arg4 As Integer, arg5 As String) As Variant

    Static dict As Object
    Dim k As String, rv
    Dim oConnection As ADODB.Connection
    Dim oRecordset As ADODB.Recordset
    Dim strSQL As String

    'create the dictionary if not already created
    If dict Is Nothing Then
        Set dict = CreateObject("scripting.dictionary")
    End If

    'create a unique "key" from the arguments
    k = Join(Array(arg1, arg2, arg3, arg4, arg5), Chr(0))

    'need to run this query?
    If Not dict.exists(k) Then

        Set oConnection = New ADODB.Connection
        Set oRecordset = New ADODB.Recordset

        strSQL = "SELECT SUM(BALANCE) as Total FROM Accounting WHERE ARGUMENT1 = '" & _
                 arg1 & "' AND ARGUMENT2 = '" & arg2 & _
                 "' AND ARGUMENT3 = '" & arg3 & "' AND ARGUMENT4 = " & arg4 & _
                 "  AND ARGUMENT5 = " & arg5 & ""

        oConnection.Open "Provider=SQLOLEDB;" & _
                             "Data Source=(IP of database);" & _
                             "Initial Catalog=(catalog of database);" & _
                             "Trusted_connection=yes;"

        oRecordset.Open Source:=strSQL, ActiveConnection:=oConnection, _
                        CursorType:=adOpenForwardOnly, LockType:=adLockReadOnly, _
                        Options:=adCmdText


        rv = oRecordset!Total

        dict.Add k, rv

        oRecordset.Close
        Set oRecordset = Nothing

    Else
        'already ran the SQL - just return the result
        rv = dict(k)
    End If

    Test = rv

End Function

来源：https://stackoverflow.com/questions/34048266/excel-vba-function-with-recordset-performance-issue

标签

excel

vba

excel-vba

recordset