如何用Excel VBA批量执行SQL查询并合并结果至RESULT工作表

问题描述 #

我在query工作表的C列存储了数量不固定的SQL查询语句，需要用VBA逐个执行这些查询，将结果写入RESULT工作表：第一个查询需带出表头，后续查询结果不带表头，依次追加在前一个结果的下方。但现有代码仅能执行C2单元格的查询，无法实现批量执行需求。

现有代码 #

Sub DCPARAMS()
 Dim DBcon As ADODB.Connection
    Dim DBrs As ADODB.Recordset
    Set DBcon = New ADODB.Connection
    Set DBrs = New ADODB.Recordset

Dim SSDF_SSDF As Workbook


Application.ScreenUpdating = False
Application.DisplayAlerts = False

   Dim DBQuery As String
    Dim ConString As String
    Dim SQL_query As String
    Dim User As String
    Dim Password As String
    Dim RowsCount As Double
            
    Dim intColIndex As Double
    
    DBrs.CursorType = adOpenDynamic
    DBrs.CursorLocation = adUseClient
    
Windows("SSDF MACRO.xlsm").Activate
Set SSDF_SSDF = ActiveWorkbook
        
 User = SSDF_SSDF.Sheets("MACROS").Range("B4").Value
 
 Password = SSDF_SSDF.Sheets("MACROS").Range("B5").Value


'error handling
On Error GoTo err
'I WANT THIS VALUE TO CHANGE BASED ON QUERY SHEETS COLUMN C
**SQL_query = Worksheets("query").Range("C2").Value**

' DELETING OLD VALUES


SSDF_SSDF.Sheets("RESULT").Select
SSDF_SSDF.Sheets("RESULT").Range("A1:Q1000000").Select
Selection.ClearContents
If User = "" Then MsgBox "Please fill in your user ID first"
If User = "" Then Exit Sub
If Password = "" Then MsgBox "Please fill in your Password first"
If Password = "" Then Exit Sub

'Open the connection using Connection String
    DBQuery = "" & SQL_query
    ConString = "Driver={Oracle in OraClient12Home1_32bit};Dbq=prismastand.world;Uid=" & User & ";Pwd=" & Password & ";"
    DBcon.Open (ConString) 'Connecion to DB is made
'below statement will execute the query and stores the Records in DBrs
    DBrs.Open DBQuery, DBcon
     
    If Not DBrs.EOF Then 'to check if any record then
' Spread all the records with all the columns
' in your sheet from Cell A2 onward.
        SSDF_SSDF.Sheets("RESULT").Range("A2").CopyFromRecordset DBrs
'Above statement puts the data only but no column
'name. hence the below for loop will put all the
'column names in your excel sheet.
      For intColIndex = 0 To DBrs.Fields.Count - 1
           Sheets("RESULT").Cells(1, intColIndex + 1).Value = DBrs.Fields(intColIndex).Name
      Next
        RowsCount = DBrs.RecordCount
    End If
   
    
   
'Close the connection
    DBcon.Close
    
'Informing user
       Worksheets("REUSLT").Select
If Range("A2").Value <> "" Then
    MsgBox "ALL GOOD, RUN NEXT MACRO"
    Else: MsgBox "DATA IS MISSING IN DB PLEASE CHECK"
 Exit Sub
End If
    
    'alerts
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Windows("SSDF MACRO.xlsm").Activate
SSDF_SSDF.Sheets("dc").Select
    Exit Sub
err:
    MsgBox "Following Error Occurred: " & vbNewLine & err.Description
    DBcon.Close
    'alerts
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

修改后的代码（实现批量执行+结果追加） #

Sub DCPARAMS_Batch()
    Dim DBcon As ADODB.Connection
    Dim DBrs As ADODB.Recordset
    Set DBcon = New ADODB.Connection
    Set DBrs = New ADODB.Recordset

    Dim SSDF_SSDF As Workbook
    Dim wsQuery As Worksheet, wsResult As Worksheet
    Dim lastRowQuery As Long, nextRowResult As Long
    Dim i As Long
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim DBQuery As String
    Dim ConString As String
    Dim SQL_query As String
    Dim User As String
    Dim Password As String
    Dim intColIndex As Double
    
    DBrs.CursorType = adOpenDynamic
    DBrs.CursorLocation = adUseClient
    
    Set SSDF_SSDF = ThisWorkbook
    Set wsQuery = SSDF_SSDF.Sheets("query")
    Set wsResult = SSDF_SSDF.Sheets("RESULT")
        
    User = SSDF_SSDF.Sheets("MACROS").Range("B4").Value
    Password = SSDF_SSDF.Sheets("MACROS").Range("B5").Value

    ' 校验用户信息
    If User = "" Then
        MsgBox "请先填写用户ID"
        GoTo Cleanup
    End If
    If Password = "" Then
        MsgBox "请先填写密码"
        GoTo Cleanup
    End If

    ' 清空RESULT表旧数据
    wsResult.Range("A1:Q1000000").ClearContents
    nextRowResult = 1 ' 初始写入行号
    
    ' 获取query表C列最后一行
    lastRowQuery = wsQuery.Cells(wsQuery.Rows.Count, "C").End(xlUp).Row
    
    ' 遍历所有SQL语句（从C2开始）
    For i = 2 To lastRowQuery
        SQL_query = wsQuery.Cells(i, "C").Value
        If Trim(SQL_query) = "" Then GoTo NextQuery ' 跳过空单元格
        
        ' 打开数据库连接（仅首次打开，避免重复连接）
        If DBcon.State <> adStateOpen Then
            ConString = "Driver={Oracle in OraClient12Home1_32bit};Dbq=prismastand.world;Uid=" & User & ";Pwd=" & Password & ";"
            DBcon.Open ConString
        End If
        
        ' 执行查询
        DBQuery = SQL_query
        Set DBrs = DBcon.Execute(DBQuery)
        
        ' 处理查询结果
        If Not DBrs.EOF Then
            ' 第一个查询写入表头
            If i = 2 Then
                For intColIndex = 0 To DBrs.Fields.Count - 1
                    wsResult.Cells(nextRowResult, intColIndex + 1).Value = DBrs.Fields(intColIndex).Name
                Next
                nextRowResult = nextRowResult + 1 ' 表头写入后，行号+1
            End If
            
            ' 写入数据
            wsResult.Cells(nextRowResult, 1).CopyFromRecordset DBrs
            
            ' 更新下一次写入的行号
            nextRowResult = nextRowResult + DBrs.RecordCount
        End If
        
        DBrs.Close
        
NextQuery:
    Next i
    
    ' 提示执行结果
    If wsResult.Range("A2").Value <> "" Then
        MsgBox "执行完成，可运行下一个宏"
    Else
        MsgBox "数据库中无数据，请检查"
    End If

Cleanup:
    ' 关闭连接和对象
    If DBcon.State = adStateOpen Then DBcon.Close
    Set DBrs = Nothing
    Set DBcon = Nothing
    
    ' 恢复设置
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    SSDF_SSDF.Sheets("dc").Select
    Exit Sub
    
err:
    MsgBox "发生错误：" & vbNewLine & Err.Description
    GoTo Cleanup
End Sub

关键修改说明 #

1. 批量遍历SQL语句：通过lastRowQuery获取C列最后一行，用For循环遍历C2到最后一行的所有非空SQL语句
2. 结果追加逻辑：用nextRowResult记录下一次写入的行号，每次写入数据后更新该值，实现结果依次追加
3. 表头控制：仅在第一次循环（i=2）时写入查询表头，后续循环只写入数据
4. 优化连接效率：仅在连接未打开时建立数据库连接，避免重复连接开销
5. 移除冗余操作：删除原代码中不必要的Select/Selection操作，直接通过工作表对象操作，提升代码效率
6. 修复拼写错误：修正原代码中Worksheets("REUSLT")的拼写错误（应为RESULT）

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