如何在Excel拆分区域中复制ADODB.RecordSet内容？

问题原因 #

CopyFromRecordset 不会识别 Union 创建的非连续区域分组，它只会从目标区域的左上角单元格开始，按工作表的连续单元格顺序（从左到右、从上到下）填充数据。你的代码中，Union区域的左上角是A1，所以RecordSet的4个字段会依次写入A1→B1→C1→D1，完全跳过了E1，这就是为什么没达到“跳过C1”的预期。

可行解决方案 #

以下两种方法都能满足你“减少写入事件”的需求，且后续可复用Union区域：

方法1：将RecordSet转存数组后分块写入 #

先把RecordSet数据存入数组，再通过Union区域的Areas属性，分别给A1:B1和D1:E1赋值，仅需2次写入操作：

Dim conn As ADODB.Connection
Dim QueryResults As ADODB.Recordset
Dim sConnString As String
Dim QuerySql As String
Dim Unione As Range
Dim rsData As Variant

Set conn = New ADODB.Connection
Set QueryResults = New ADODB.Recordset
sConnString = "Provider=SQLOLEDB;Data Source=DB_IP_ADDRESS;Initial Catalog=DB_CATALOG;Persist Security Info=True;User ID=DB_USER_ID;Password=DB_USER_PASSWORD;"
QuerySql = "Select field_1,field_2,field_3,field_4 from table"

conn.Open sConnString
Set QueryResults = conn.Execute(QuerySql)

Set Unione = Union( _
    Sheets("FoglioMonda").Range("A1:B1"), _
    Sheets("FoglioMonda").Range("D1:E1") _
)

' 将RecordSet数据转为数组（GetRows返回列优先数组，需转置为行优先）
rsData = QueryResults.GetRows
rsData = Application.Transpose(rsData)

' 分块写入Union的两个区域
Unione.Areas(1).Value = rsData(1, 1).Resize(1, 2)
Unione.Areas(2).Value = rsData(1, 3).Resize(1, 2)

' 清理资源
QueryResults.Close
conn.Close
Set QueryResults = Nothing
Set conn = Nothing

方法2：先写入临时连续区域，再复制到Union区域 #

如果RecordSet数据量较大，这种方法更直观，同样仅需2次写入操作：

Dim conn As ADODB.Connection
Dim QueryResults As ADODB.Recordset
Dim sConnString As String
Dim QuerySql As String
Dim Unione As Range
Dim tempRange As Range

Set conn = New ADODB.Connection
Set QueryResults = New ADODB.Recordset
sConnString = "Provider=SQLOLEDB;Data Source=DB_IP_ADDRESS;Initial Catalog=DB_CATALOG;Persist Security Info=True;User ID=DB_USER_ID;Password=DB_USER_PASSWORD;"
QuerySql = "Select field_1,field_2,field_3,field_4 from table"

conn.Open sConnString
Set QueryResults = conn.Execute(QuerySql)

Set Unione = Union( _
    Sheets("FoglioMonda").Range("A1:B1"), _
    Sheets("FoglioMonda").Range("D1:E1") _
)
' 定义一个临时连续区域（可选择不影响业务的位置）
Set tempRange = Sheets("FoglioMonda").Range("F1:I1")

' 一次性写入临时区域
tempRange.CopyFromRecordset QueryResults
' 分别复制到目标区域
Unione.Areas(1).Value = tempRange.Resize(1, 2).Value
Unione.Areas(2).Value = tempRange.Offset(0, 2).Resize(1, 2).Value

' 可选：清除临时区域内容
tempRange.ClearContents

' 清理资源
QueryResults.Close
conn.Close
Set QueryResults = Nothing
Set conn = Nothing

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