Recordset causing Excel togo Not Responding

Question

I am at a loss as to why a query that runs in 10-11 seconds directly is causing Excel to stop responding. Even the more filtered version of this query which has only 193 Rows x 26 Columns cause the same issue.

References enabled in order:

1. VB for Applications
2. MS Excel 16.0 Object Library
3. OLE Automation
4. MS Office 16.0 Object Library
5. MS ActiveX Data Objects 6.1 Library
6. MS Forms 2.0 Object Library
7. MS ActiveX Data Objects Recordset 2.8 Library (also tried 6.0 just in case)

I am trying to create a querytable for the record set to dump the data into:

Option Explicit
Sub Import_Data()

On Error GoTo ErrorHandler

Dim BCS As Worksheet
Dim dv As Worksheet
Dim RegAtt As Worksheet
Dim POData As Worksheet
Dim CARData As Worksheet
Dim UserDefinedFilters As String
Dim POFilters As String
Dim Site_List As String
Dim CL As String
Dim FL As String
Dim scenario_year As Integer
Dim Scenario As String
Dim RegSql As String
Dim POSql1 As String
Dim POSql2 As String
Dim POSql3 As String
Dim BCSSql1 As String
Dim BCSSql2 As String
Dim BCSSql3 As String
Dim BCSSql4 As String
Dim CS As String
Dim CS64 As String
Dim CS32 As String
Dim response As String
Dim con As ADODB.Connection
Dim Rs As Recordset
Dim rs2 As Recordset
Dim rs3 As Recordset
Dim rs4 As Recordset
Dim qt As Variant
Dim qt2 As Variant
Dim qt3 As Variant
Dim hdrs As Variant
Dim i As Variant

Set con = New ADODB.Connection
Set rs3 = CreateObject("ADODB.RECORDSET")


Call DeleteConnections

'Test for Mac
#If Mac Then
    'if Mac then use this driver
    CS = "Driver={Amazon Redshift};SERVER={<rs>};UID=<user>;PASSWORD=<pwd>;DATABASE=<db>;PORT=8192"
#ElseIf Win64 Then
    CS64 = "Driver={Amazon Redshift (x64)};SERVER={<rs>};UID=<user>;PASSWORD=<pwd>;DATABASE=<db>;PORT=8192"
    con.Open CS64
#Else
    CS32 = "Driver={Amazon Redshift (x86)};SERVER={<rs>};UID=<user>;PASSWORD=<pwd>;DATABASE=<db>;PORT=8192"
    con.Open CS32
#End If

Application.ScreenUpdating = False

'Filter Fields
Site_List = UCase(ThisWorkbook.Sheets(Sheet1.Name).Range("D1").Value)
CL = UCase(ThisWorkbook.Sheets(Sheet1.Name).Range("D2").Value)
FL = UCase(ThisWorkbook.Sheets(Sheet1.Name).Range("D3").Value)
scenario_year = ThisWorkbook.Sheets(Sheet1.Name).Range("D4").Value
Scenario = "'" & ThisWorkbook.Sheets(Sheet1.Name).Range("D5").Value & "'"

'POData Filters
If CL <> "" And FL <> "" Then
    CL = Replace(CL, ", ", ",")
    FL = Replace(FL, ", ", ",")
    POFilters = POFilters & "UPPER(LEFT(po.po_fbn,3)) in ('" & Replace(CL, ",", "','") & "') " & _
    vbNewLine & " AND UPPER(po.po_bn) in ('" & Replace(FL, ",", "','") & "') "

ElseIf CL <> "" And FL = "" Then
    CL = Replace(CL, ", ", ",")
    POFilters = POFilters & "UPPER(LEFT(po.po_bn,3)) in ('" & Replace(CL, ",", "','") & "') "

ElseIf CL = "" And FL <> "" Then
    If InStr(1, FBNList, ",") > 0 Then
        FL = Replace(FL, ", ", ",")
        POFilters = POFilters & " UPPER(po.po_bn) in ('" & Replace(UCase(FL), ",", "','") & "') "
    ElseIf InStr(1, FL, "*") > 0 Then
        POFilters = POFilters & " UPPER(po.po_bn) LIKE '%" & Replace(UCase(FL), "*", "") & "%' "
    Else
        POFilters = POFilters & " UPPER(po.po_bn) in ('" & UCase(FL) & "') "
    End If
End If

'This is to refresh PO Data for Look Up
Set POData = ThisWorkbook.Sheets(Sheet5.Name)
POData.Cells.Clear
Sql1 = "WITH build_filter_1 AS ( SELECT build_id FROM dcgs.build_schedule WHERE build_id LIKE '%DCA%')," & _
       "build_filter_2 AS ( SELECT build_id FROM dcgs.build_schedule WHERE NOT build_id LIKE '%DCA%' AND build_id LIKE '%.001%')," & _
       "build_data AS ( SELECT fbn, CASE WHEN cluster ILIKE'%UNK%' THEN LEFT ( fbn, 3 ) ELSE cluster END AS region, site " & _
       "FROM dcgs.build_schedule " & _
       "WHERE ( fbn LIKE'%ROM%' OR fbn LIKE'%PRX%' OR fbn LIKE'%IGL%' ) " & _
       "AND  build_id IN ( SELECT * FROM build_filter_1 UNION ALL SELECT * FROM build_filter_2) " & _
       "AND NOT build_status = 'CANCELED'), "

Sql2 = Sql1 & vbNewLine & _
       "po AS ( SELECT aa.organization, aa.po_number, aa.po_line_number, aa.buyer, aa.requester, " & _
       "aa.po_creation_date, aa.po_close_status, TRIM ( aa.fbn ) AS po_fbn, aa.project, aa.currency, " & _
       "aa.unit_price, ROUND(aa.quantity,2) AS quantity, ROUND(aa.quantity_received,2) AS quantity_received, " & _
       "ROUND(aa.adjamtord,2) AS amount_ordered, ROUND(aa.adjamtbil,2) AS amount_billed, " & _
       "aa.vendor, REGEXP_REPLACE( aa.item_description, '[^[:alnum:]]', ' ' ) AS item_description, " & _
       "aa.car_lines, aa.category AS po_category, aa.sub_category, aa.exchange_rate, " & _
       "CASE WHEN aa.car_Lines = 'Design_and_Engineering' THEN 'Design' " & _
       "WHEN aa.car_Lines = 'Electrical' THEN 'Electrical_Equipment' " & _
       "WHEN aa.car_Lines = 'Mechanical' THEN 'Mechanical_Equipment' ELSE aa.car_Lines END category1, " & _
       "b.qty_subcategory, b.value_subcategory, cr.line_category_renamed, " & _
       "CASE WHEN ca.car_classification = 'Boomerang' THEN 'Yes' ELSE 'No' END AS car_exceptions, " & _
       "ROW_NUMBER() OVER ( PARTITION BY aa.project, aa.po_number, aa.item_description ) AS dedupe " & _
       "FROM awscfpa.dcgs.po_new aa " & _
       "LEFT JOIN dcgs.invoice_att b ON b.item_desc = aa.item_description " & _
       "LEFT JOIN dcgs.cat_rename cr ON cr.line_category = aa.category " & _
       "LEFT JOIN dcgs.car_att ca ON ca.car_num = aa.project " & _
       "WHERE aa.car_lines <> 'Network' AND aa.acct_type = 'CapEx' " & _
       "AND ( aa.Quantity <> 0 OR aa.Quantity_Received <> 0 OR aa.Amount_Billed <> 0 OR aa.Amount_Ordered <> 0 OR aa.AdjAmtBil <> 0 OR aa.AdjAmtOrd <> 0 ) " & _
       "AND TRIM ( aa.fbn ) IN ( SELECT TRIM ( fbn ) FROM build_data ))"

If POFilters = "" Then
Sql3 = Sql2 & vbNewLine & _
       "SELECT po.organization, po.po_number, po.po_line_number, po.buyer, po.requester, po.po_creation_date," & _
       "po.po_close_status, po.po_fbn, po.project, po.currency, po.unit_price, po.quantity, po.quantity_received," & _
       "po.amount_ordered, po.amount_billed, po.vendor, po.item_description, po.car_lines, po.po_category," & _
       "po.sub_category, po.exchange_rate, po.category1, po.qty_subcategory, po.value_subcategory, po.line_category_renamed, po.car_exceptions " & _
       "FROM po WHERE dedupe = 1"
Else
Sql3 = Sql2 & vbNewLine & _
       "SELECT po.organization, po.po_number, po.po_line_number, po.buyer, po.requester, po.po_creation_date," & _
       "po.po_close_status, po.po_fbn, po.project, po.currency, po.unit_price, po.quantity, po.quantity_received," & _
       "po.amount_ordered, po.amount_billed, po.vendor, po.item_description, po.car_lines, po.po_category," & _
       "po.sub_category, po.exchange_rate, po.category1, po.qty_subcategory, po.value_subcategory, po.line_category_renamed, po.car_exceptions " & _
       "FROM po WHERE " & POFilters & " AND dedupe = 1"


End If

rs3.ActiveConnection = con
rs3.Open Sql3

Set qt3 = POData.ListObjects.Add(SourceType:=XlListObjectSourceType.xlSrcQuery, _
        Source:=rs3, Destination:=POData.Range("A1")).QueryTable

qt3.Refresh
rs3.Close

Application.ScreenUpdating = True
Exit Sub

ErrorHandler:
Call DeleteConnections
MsgBox ("Report has encountered an error:" & vbNewLine & Err.Number & " - " & Err.Description & vbNewLine & "Please reach out to <email> for a solution.")

Application.ScreenUpdating = True
End Sub

I have two other recordsets that are the same code, with different queries, which work without issue. One of the different queries is 64 Rows x 18 Columns, but it has a cross join and it takes about 10 seconds to run as well.

I also tried to change how the recordset is entered with CopyFromRecordset and it does the same thing. When I Debug.Print rs3.RecordCount I get -1 which I suspect is not unexpected since this is Redshift and it likely can't tell how many there are.

This one causes excel to not respond and I have no idea why or how to troubleshoot it.

1. Is there a way to troubleshoot the problem?
2. Is there a better way to get this data into excel from Redshift?

EDIT:

I tried doing the following:

con.CommandTimeout = 60
Set rs3 = con.Execute(POSql3)

If Not rs3.EOF Then
    With POData
        .Activate
        .Range("A1").CopyFromRecordset rs3
    End With
End If

I get the following error:

-2147217887 - Multiple-step OLE DB operation generated errors. Check each OLE DB status value, if available. No work was done.

Not sure what to do with that.

Answer 1

What follows is a code pattern, you will need to adopt and adapt. In a class called AsyncQuery add the following code

Option Explicit

Private WithEvents cnAsynchronousConnection As ADODB.Connection

Public Sub RunAsyncQuery()

    Set cnAsynchronousConnection = New ADODB.Connection

    cnAsynchronousConnection.connectionString = "<my conn string>" '<---- Insert your connection string


    cnAsynchronousConnection.Open

    Debug.Print "Preparing to execute asynchronously: " & Now
    cnAsynchronousConnection.Execute "<select query>", adAsyncExecute  '<----- Insert you own query

    Debug.Print "Has begun executing asynchronously: " & Now
End Sub

Private Sub cnAsynchronousConnection_ExecuteComplete(ByVal RecordsAffected As Long, _
        ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pCommand As ADODB.Command, _
        ByVal pRecordset As ADODB.Recordset, ByVal pConnection As ADODB.Connection)
    Debug.Print "The query has completed asynchronously: " & Now
End Sub

Then in a standard module add the following code Option Explicit

Sub Test()
    Dim oAsyncQuery As AsyncQuery
    Set oAsyncQuery = New AsyncQuery

    oAsyncQuery.RunAsyncQuery

End Sub

This gives asynchronous query execution. I'm sorry I'm not in a position to debug your queries but at least Excel will remain responsive.

I created this code on my blog first

Answer 2

Too long for a comment, but try adding some timing...

Dim t, n As Long

t = Timer
rs3.ActiveConnection = con
Debug.Print "Connected", Timer-t
rs3.Open Sql3
Debug.Print "Opened recordset", Timer-t

Do While Not rs3.EOF
    n = n + 1
    If n Mod 20 = 0 Then Debug.Print "Fetched " & n, Timer - t
    rs3.MoveNext
Loop
Debug.Print "Completed (" & n & " records )", Timer - t

What output do you see?

Answer 3

I see few possible reasons of MS Excel does not response during execution of your code.

1. There's too many subqueries. Try to decrease the number of subqueries by using JOIN's.
2. When you use Open method, recordset is opening in CursorType=adOpenForwardOnly mode, which is good if you want to scroll forward through records. I'd suggest to use adOpenStatic to generate static report. You can use other optional parameters which may improve query execution. See: ADODB.Recordset.Open method
3. qt3.Refresh command causes MS Excel to re-query of data. So, this command seems to be redundant, because you refer to newly created recordset. See: QueryTable.Refresh method