VBA code slow to process. asynchronous fetch for sql statement?

[tasxj]

I have been tasked with a project to display a list referenced to a specific criteria. I know I can do this in the local environment but choose to move to the vba side for simplicity and hopefully speed.

Problem is that its slow. I have 2 active x buttons on the "view" tab, The first one is to update the combo boxes by searching the data$ tab for unique values.

I figure that I could build a named range and reference that in the script instead of searching through the data set.

the second button is "show data" this displays the user selected criteria in a named range. I was reading that I could run an asynchronous fetch instead of synchronous fetch so that the code can move along and populate the named range. I was trying to search and find examples so that I could implement it but my familiarity with vba is limited and I am learning this as I go. I have only been dabbling in vba for about 3 years mostly using the macro recorder and then modifying the code to clean it up. I am also learning sql at the same time so please excuse any ignorance on my part.

The below code was borrowed and modified for my use. don't mind the 'strsql comments. these were left in after the borrowed code had to be debugged.

This is the code in module one that defines my constants for the connection and recordset

Option Explicit
Public cnn As New ADODB.Connection
Public rs As New ADODB.Recordset
Public strSQL As String

Public Sub OpenDB()
    If cnn.State = adStateOpen Then cnn.Close
    cnn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ=" & _
    ActiveWorkbook.Path & Application.PathSeparator & ActiveWorkbook.Name
    cnn.Open
End Sub

Public Sub closeRS()
    If rs.State = adStateOpen Then rs.Close
    rs.CursorLocation = adUseClient
End Sub

code for the functions on the view tab.

Private Sub cmbYear_Change()

End Sub

Private Sub cmdReset_Click()
    'clear the data
    cmbPartNumber.Clear
    cmbMonth.Clear
    cmbyear.Clear
    Sheets("View").Visible = True
    Sheets("View").Select
    Range("dataSet").Select
    Range(Selection, Selection.End(xlDown)).ClearContents
End Sub

Private Sub cmdShowData_Click()
    'populate data
    strSQL = "SELECT * FROM [Data$] WHERE "
    If cmbPartNumber.Text <> "" Then
        strSQL = strSQL & " [PartNumber]='" & cmbPartNumber.Text & "'"
    End If
    
    If cmbMonth.Text <> "" Then
        If cmbPartNumber.Text <> "" Then
            strSQL = strSQL & " AND [Month]='" & cmbMonth.Text & "'"
        Else
            strSQL = strSQL & " [Month]='" & cmbMonth.Text & "'"
        End If
    End If

    If cmbyear.Text <> "" Then
        If cmbPartNumber.Text <> "" Or cmbMonth.Text <> "" Then
            'strSQL = strSQL & " AND [Year]='" & cmbyear.Text & "'"
            strSQL = strSQL & " AND [Year]= 2012"
        Else
            'strSQL = strSQL & " [Year]='" & cmbyear.Text & "'"
            strSQL = strSQL & " [Year]= 2012"
        End If
    End If
    
    If cmbPartNumber.Text <> "" Or cmbMonth.Text <> "" Or cmbyear.Text <> "" Then
        'now extract data
        closeRS
        
        OpenDB
        
        rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
        If rs.RecordCount > 0 Then
            Sheets("View").Visible = True
            Sheets("View").Select
            Range("dataSet").Select
            Range(Selection, Selection.End(xlDown)).ClearContents
            
            'Now putting the data on the sheet
            ActiveCell.CopyFromRecordset rs
        Else
            MsgBox "I was not able to find any matching records.", vbExclamation + vbOKOnly
            Exit Sub
        End If

        'Now getting the totals using Query
        If cmbPartNumber.Text <> "" And cmbMonth.Text <> "" And cmbyear.Text <> "" Then
            strSQL = "SELECT Count([Data$].[LotNumber]) AS [CountOfLotNumber]" & _
            " FROM [Data$] WHERE ((([Data$].[PartNumber]) = '" & cmbPartNumber.Text & "' ) And " & _
            " (([Data$].[Month]) =  '" & cmbMonth.Text & "' ) And (([Data$].[Year]) =  " & cmbyear.Text & " )) " & _
            ";"
            
            closeRS
            OpenDB
            
            rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
            If rs.RecordCount > 0 Then
                Range("L6").CopyFromRecordset rs
            Else
                Range("L6:M7").Clear
                MsgBox "There was some issue getting the totals.", vbExclamation + vbOKOnly
                Exit Sub
            End If
        End If
    End If
End Sub

Private Sub cmdUpdateDropDowns_Click()
    strSQL = "Select Distinct [PartNumber] From [data$] where not (IsNull([PartNumber]))Order by [PartNumber]"
    closeRS
    OpenDB
    cmbPartNumber.Clear
    
    rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
    If rs.RecordCount > 0 Then
        Do While Not rs.EOF
            cmbPartNumber.AddItem rs.Fields(0)
            rs.MoveNext
        Loop
    Else
        MsgBox "I was not able to find any unique Part Numbers.", vbCritical + vbOKOnly
        Exit Sub
    End If
    
    '----------------------------
    strSQL = "Select Distinct [Month] From [data$] where not (IsNull([Month])) Order by [Month]"
    closeRS
    OpenDB
    cmbMonth.Clear
    
    rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
    If rs.RecordCount > 0 Then
        Do While Not rs.EOF
            cmbMonth.AddItem rs.Fields(0)
            rs.MoveNext
        Loop
    Else
        MsgBox "I was not able to find any unique Month(s).", vbCritical + vbOKOnly
        Exit Sub
    End If
    '----------------------
    strSQL = "Select Distinct [Year] From [data$] where not (IsNull([Year])) Order by [Year]"
    closeRS
    OpenDB
    cmbyear.Clear
    
    rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
    If rs.RecordCount > 0 Then
        Do While Not rs.EOF
            cmbyear.AddItem rs.Fields(0)
            rs.MoveNext
        Loop
    Else
        MsgBox "I was not able to find any unique Year(s).", vbCritical + vbOKOnly
        Exit Sub
    End If
End Sub






Private Sub Label1_Click()

End Sub