Excel VBA Recordset导致Excel无法响应

我不知道为什么直接在10-11秒内运行的查询会导致Excel停止响应。即使此查询的筛选版本更高,只有193行x 26列,也会导致相同的问题。

引用按顺序启用:

  1. 应用程序的VB
  2. MS Excel 16.0对象库
  3. OLE自动化
  4. MS Office 16.0对象库
  5. MS ActiveX数据对象6.1库
  6. MS Forms 2.0对象库
  7. MS ActiveX数据对象Recordset 2.8库(也尝试使用6.0以防万一)

我正在尝试为将数据转储到的记录集创建查询表:

Sub Import_Data()

On Error GoTo ErrorHandler

Dim BCS As Worksheet
Dim POData As Worksheet
Dim UserDefinedFilters As String
Dim Site_List As String
Dim Cluster_List As String
Dim con As ADODB.Connection

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

我还有两个其他记录集,它们是相同的代码,带有不同的查询,可以正常工作。不同的查询之一是64行x 18列,但它具有交叉联接,并且大约需要10秒钟才能运行。

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.

这导致excel无法响应,我也不知道为什么或如何解决它。

  1. 有没有办法解决问题?
  2. 有没有更好的方法可以将数据从Redshift导入excel?