Excel VBA连接Redshift集群查询性能优化及ADODB连接问题求助

首先，咱们先解决最核心的性能问题——你用ListObject.QueryTable慢到离谱，主要是因为这个组件在处理大数据量时，会产生大量Excel UI交互开销（比如逐行插入单元格、实时调整列宽等）。而ADODB Recordset直接写入单元格的方式，能把速度提升一个数量级，同时我也会帮你搞定ADODB的连接错误，再给你优化WHERE子句的构建逻辑，让代码更易维护。

一、性能提升：改用ADODB Recordset直接写入数据 #

这是解决你980秒耗时问题的关键。QueryTable本质上是封装了ADODB，但额外做了很多UI相关的操作，而直接用CopyFromRecordset一次性写入数据，能跳过这些冗余开销。先给你修正ADODB的连接问题，再给完整代码：

1. 修正ADODB连接字符串 #

你之前的错误有两个：一是参数值加了不必要的大括号（比如{RS1.us-east-1.redshift.amazonaws.com}），驱动识别不了；二是参数名用了非标准的ID/PASSWORD，Redshift官方驱动的标准参数是UID和PWD。正确的无DSN连接字符串是：

CS = "Driver={Amazon Redshift (x64)};SERVER=RS1.us-east-1.redshift.amazonaws.com;PORT=8192;DATABASE=db1;UID=user;PWD=fakepasswrod;sslmode=require"

2. 完整的ADODB写入代码 #

直接把Recordset数据一次性写入Excel，比QueryTable快N倍：

Sub FetchRedshiftData()
    Dim conn As Object
    Dim rs As Object
    Dim ws As Worksheet
    Dim startCell As Range
    Dim sqlStr As String
    Dim finalWhere As String ' 你构建的WHERE子句
    
    ' 替换成你的目标工作表
    Set ws = ThisWorkbook.Sheets(Sheet6.Name)
    Set startCell = ws.Range("$A$1")
    
    ' 关闭Excel的后台开销（必须！）
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' 清空旧数据
    ws.Cells.Clear
    
    ' 初始化ADODB对象
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    
    ' 建立连接
    On Error GoTo ConnectionError
    CS = "Driver={Amazon Redshift (x64)};SERVER=RS1.us-east-1.redshift.amazonaws.com;PORT=8192;DATABASE=db1;UID=user;PWD=fakepasswrod;sslmode=require"
    conn.Open CS
    
    ' 替换成你的完整SQL（包含你构建的WHERE子句）
    finalWhere = BuildWhereClause() ' 调用你优化后的WHERE构建函数
    sqlStr = "SELECT cl,reg,curr FROM schema.table1" & finalWhere
    
    ' 执行查询，用静态游标+只读锁定提升性能（用数字常量兼容所有Excel版本）
    rs.Open sqlStr, conn, 3, 1 ' adOpenStatic=3, adLockReadOnly=1
    
    ' 写入表头
    Dim i As Integer
    For i = 0 To rs.Fields.Count - 1
        startCell.Offset(0, i).Value = rs.Fields(i).Name
    Next i
    
    ' 一次性写入所有数据（这一步是速度的关键！）
    If Not rs.EOF Then
        startCell.Offset(1, 0).CopyFromRecordset rs
    End If
    
    ' 清理资源
    Cleanup:
    rs.Close
    conn.Close
    Set rs = Nothing
    Set conn = Nothing
    
    ' 恢复Excel设置
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    ' 可选：把数据转成ListObject
    With ws.ListObjects.Add(xlSrcRange, ws.Range(startCell, startCell.Offset(rs.RecordCount, rs.Fields.Count - 1)), , xlYes)
        .DisplayName = "LO_2"
        .AdjustColumnWidth = True
    End With
    
    Exit Sub
    
    ' 错误处理
    ConnectionError:
    MsgBox "连接失败：" & Err.Description, vbCritical
    GoTo Cleanup
End Sub

二、优化WHERE子句构建逻辑（减少冗余代码） #

你现在的IF语句堆得太乱，容易出错，用通用函数来构建IN/ LIKE条件，能大幅简化代码：

通用条件构建函数 #

Function BuildWhereClause() As String
    Dim UserDefinedFilters As String
    Dim BCSFilters As String
    
    ' 读取过滤参数（可以封装成单独的函数，更清晰）
    Dim C_List As String, S_List As String, F_List As String
    Dim cat As String, subcat As String
    C_List = UCase(Trim(ThisWorkbook.Sheets(Sheet1.Name).Range("D1").Value))
    S_List = UCase(Trim(ThisWorkbook.Sheets(Sheet1.Name).Range("D2").Value))
    F_List = UCase(Trim(ThisWorkbook.Sheets(Sheet1.Name).Range("D3").Value))
    cat = UCase(Trim(ThisWorkbook.Sheets(Sheet1.Name).Range("D10").Value))
    subcat = UCase(Trim(ThisWorkbook.Sheets(Sheet1.Name).Range("D11").Value))
    
    ' 检查是否无过滤
    If C_List = "" And S_List = "" And F_List = "" Then
        If MsgBox("未选择任何过滤条件，将拉取全部数据，是否继续？", vbYesNo) = vbNo Then
            Call DeleteConnections
            BuildWhereClause = ""
            Exit Function
        End If
    End If
    
    ' 构建用户定义过滤条件
    UserDefinedFilters = ""
    UserDefinedFilters = UserDefinedFilters & BuildInCondition("UPPER(s)", S_List)
    UserDefinedFilters = UserDefinedFilters & BuildInCondition("UPPER(reg)", C_List)
    UserDefinedFilters = UserDefinedFilters & BuildLikeCondition("UPPER(bd.f)", F_List)
    
    ' 构建分类过滤条件
    BCSFilters = ""
    BCSFilters = BCSFilters & BuildInCondition("UPPER(sca.cat)", cat)
    BCSFilters = BCSFilters & BuildInCondition("UPPER(sca.subcat)", subcat)
    
    ' 组合最终WHERE子句（去掉开头多余的AND）
    Dim finalWhere As String
    finalWhere = UserDefinedFilters & BCSFilters
    If finalWhere <> "" Then
        BuildWhereClause = " WHERE " & Mid(finalWhere, 5)
    Else
        BuildWhereClause = ""
    End If
End Function

' 构建IN条件的辅助函数
Function BuildInCondition(fieldName As String, inputValue As String) As String
    inputValue = Trim(inputValue)
    If inputValue = "" Or inputValue = "ALL" Then
        BuildInCondition = ""
        Exit Function
    End If
    
    ' 处理逗号分隔，转义单引号防止SQL注入
    Dim valuesArray As Variant
    valuesArray = Split(Replace(inputValue, ", ", ","), ",")
    Dim i As Integer
    For i = LBound(valuesArray) To UBound(valuesArray)
        valuesArray(i) = "'" & Replace(valuesArray(i), "'", "''") & "'"
    Next i
    
    BuildInCondition = " AND " & fieldName & " IN (" & Join(valuesArray, ", ") & ")"
End Function

' 构建LIKE条件的辅助函数（支持通配符）
Function BuildLikeCondition(fieldName As String, inputValue As String) As String
    inputValue = Trim(inputValue)
    If inputValue = "" Or inputValue = "ALL" Then
        BuildLikeCondition = ""
        Exit Function
    End If
    
    ' 处理通配符，转义单引号
    inputValue = Replace(inputValue, "*", "%")
    inputValue = "'%" & Replace(inputValue, "'", "''") & "%'"
    
    BuildLikeCondition = " AND " & fieldName & " LIKE " & inputValue
End Function

这样你的WHERE子句构建代码从几十行IF变成了几个函数调用，不仅易读，还能避免重复代码，同时处理了SQL注入的风险（虽然是内部用户，但转义单引号是好习惯）。

三、额外性能优化建议 #

1. 复用ADODB连接：如果要执行多个查询，不要每次都新建连接，复用同一个连接对象，减少连接建立的开销（Redshift建立连接需要一定时间）。
2. Redshift端优化：确保你的查询用到了合适的排序键和分布键——比如经常过滤的字段设置为排序键，这样Redshift能快速过滤数据，减少返回给Excel的数据量。
3. 延迟列宽调整：在写入数据时不要开启AdjustColumnWidth，等数据全部写入后再手动调整，减少UI开销。
4. 分页查询（可选）：如果数据量特别大（比如几十万行），可以分成多个小查询分页拉取，避免Excel内存溢出，但CopyFromRecordset已经能处理大部分常规数据量。

内容的提问来源于stack exchange，提问作者Shenanigator