VBA Excel Looping through recordset and storing the data to use later I have a loop to add Recordset items to a Dictionary so I can do comparisons and retrieve specific data later in the code (not shown below).

The first loop I tried takes around 17 seconds, the second takes 16 seconds, the third takes 15 seconds. It seems like a long wait to add 500-700 records. 

The connection is to a SQL Server database.

'add all apps to dictionary
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Set dict = New Scripting.Dictionary
Set rs = New ADODB.Recordset
rs.Open SQLStr2, cn, adOpenStatic

Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer

'This takes 16 seconds - class module separate
'Source: https://codereview.stackexchange.com/questions/25956/storing-recordset-data
'Dim entity As MyEntity
'Dim entities As New Collection
'While Not rs.EOF And Not rs.BOF

    'Set entity = New MyEntity
    'With entity
        '.Property1 = rs.Fields("app_number").value
        '.Property2 = rs.Fields("FlexFstDispAmt").value
        '.Property3 = rs.Fields("FlexSecDispAmt").value
        '.Property4 = rs.Fields("NonFlexAmt").value
    'End With

    'entities.Add entity 
    'rs.MoveNext 
'Wend

'this takes 15 seconds
Dim Key1 As String
Dim Key2 As String
Dim Key3 As String
Dim Key4 As String
With dict
    For i = 1 To rs.RecordCount
        Key1 = rs.Fields("app_number").value
        Key2 = rs.Fields("FlexFstDispAmt").value
        Key3 = rs.Fields("FlexSecDispAmt").value
        Key4 = rs.Fields("NonFlexAmt").value
        .Add Key1, Array(Key2, Key3, Key4)
        '.Add rs.Fields("app_number").Value, Array(rs.Fields("FlexFstDispAmt").Value, rs.Fields("FlexSecDispAmt").Value, rs.Fields("NonFlexAmt").Value)
        rs.MoveNext
    Next
End With

'this takes 17 seconds
'With dict
    'For i = 1 To rs.RecordCount
        '.Add rs.Fields("app_number").value, Array(rs.Fields("FlexFstDispAmt").value, rs.Fields("FlexSecDispAmt").value, rs.Fields("NonFlexAmt").value)
        'rs.MoveNext
    'Next
'End With

Debug.Print Round(Timer - StartTime, 2)

rs.Close
cn.Close
Set cn = Nothing
Set rs = Nothing


I'd really like some help speeding this up. Anything is appreciated.
It is much faster to iterate over an array then a recordset. You should also pass the recordset to a function to return the dictionary.  The fewer tasks a subroutine performs the better.



Function RecordsetMap(ByRef rs As ADODB.Recordset, ByVal KeyColumn As Long) As Scripting.Dictionary
    Dim Map As New Scripting.Dictionary
    Dim Key, Item, Values
    Rem 1000000 is used to ensure all rows are returned
    Values = rs.GetRows(1000000)

    Dim r As Long, c As Long

    For r = 0 To UBound(Values, 2)
        ReDim Item(0 To UBound(Values))

        For c = 0 To UBound(Values)
            Item(c) = Values(c, r)
        Next
        Key = Item(KeyColumn)
        Map.Add Key:=Key, Item:=Item
    Next

    Set RecordsetMap = Map

End Function




Usage

Dim KeyColumn As Long, n As Long

' Get Field Name Index if not know
For n = 0 To rs.Fields.Count - 1
    If rs.Fields(n).Name = "app_number" Then
        KeyColumn = n
        Exit For
    End If
Next

Set dict = RecordsetMap(rs, KeyColumn)
Dim Item, Key

Debug.Print "Iterating over Keys"
For Each Key In dict.Keys
    Item = dict(Key)
    Debug.Print Join(Item, ",")
Next

Debug.Print
Debug.Print "Iterating over Items"
For Each Item In dict.Items
    Debug.Print Join(Item, ",")
Next