记录集导致 Excel 无响应

Question

我不知道为什么直接在 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 以防万一）

我正在尝试为记录集创建一个查询表以将数据转储到：

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

我有两个其他记录集，它们的代码相同，但查询不同，它们可以正常工作。不同的查询之一是 64 Rows x 18 Columns，但它有一个交叉连接，运行也需要大约 10 秒。

我还尝试使用 CopyFromRecordset 更改记录集的输入方式，它执行相同的操作。当我 Debug.Print rs3.RecordCount 我得到 -1 时，我怀疑这并不意外，因为这是 Redshift，它可能无法判断有多少。

这个导致excel没有响应，我不知道为什么或如何解决它。

1. 有没有办法解决问题？
2. 有没有更好的方法将这些数据从 Redshift 导入到 Excel 中？

编辑：

我尝试了以下操作：

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

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

我收到以下错误：

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

不知道该怎么办。

Answer 1

以下是代码模式，您需要采用和适应。在名为 AsyncQuery 的类中添加以下代码

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

然后在一个标准模块中添加如下代码 显式选项

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

    oAsyncQuery.RunAsyncQuery

End Sub

这提供了异步查询执行。很抱歉，我无法调试您的查询，但至少 Excel 会保持响应。

我在my blog first创建了这段代码

Answer 2

评论太长，但请尝试添加一些时间...

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

你看到了什么输出？

Answer 3

我发现 MS Excel 在执行代码期间没有响应的几个可能原因。

1. 子查询太多。尝试使用JOIN's 减少子查询的数量。
2. 当您使用Open 方法时，记录集以CursorType=adOpenForwardOnly 模式打开，如果您想向前滚动记录，这很好。我建议使用adOpenStatic 生成静态报告。您可以使用其他可以改进查询执行的可选参数。见：ADODB.Recordset.Open method
3. qt3.Refresh 命令导致 MS Excel 重新查询数据。所以，这个命令似乎是多余的，因为你引用了新创建的记录集。见：QueryTable.Refresh method