使用ADODB Recordset向Excel复制数据时出现数据丢失与格式错误

用ADODB Recordset的CopyFromRecordset方法把数据粘贴到Excel时，部分列出现数据丢失、格式错误的情况，截图如下：

用到的VBA代码：

If SheetExists(conn, sheetName) Then
    ' Create a recordset for the sheet
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open "SELECT * FROM [" & sheetName & "]", conn, 3, 1
    
    ' Copy data from the recordset to the new workbook
    Dim destWs As Worksheet
    Set destWs = destWb.Sheets.Add
    'sheetname
    leng = Len(sheetName) - 1
    destWs.Name = Left(sheetName, leng)
    'Copy header
    For i = 1 To rs.Fields.Count
        destWs.Cells(1, i).Value = rs.Fields(i - 1).Name
    Next i
    'copy Data
    If Not rs.EOF Then
    destWs.Cells(2, 1).CopyFromRecordset rs
    End If
    ' Close the recordset
    rs.Close
End If

需要实现的效果：输出数据格式正确、内容完整。

解决办法 #

出现这类问题的核心原因是ADODB读取Excel数据源时，会默认根据列内前8行的数据推断列数据类型。如果后续行的数据类型和推断类型不匹配，就会被强制转换为空值或错误格式——比如某列前几行是数字，后面的文本内容就会丢失；日期格式可能被转为纯数值。以下是针对性解决方法：

1. 修改连接字符串，强制按文本读取所有列 #

在创建ADODB连接时添加IMEX=1参数，强制混合类型列按文本读取，同时指定HDR=YES确认首行是表头：

' 针对.xlsx文件的连接字符串示例
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & 源文件路径 & ";Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"";"

' 针对.xls文件的连接字符串示例
conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & 源文件路径 & ";Extended Properties=""Excel 8.0;HDR=YES;IMEX=1"";"

2. 先设置目标列格式再粘贴数据 #

在复制数据前，将目标工作表的所有列设置为文本格式，避免Excel自动转换格式：

' 放在复制表头之后、粘贴数据之前执行
destWs.Cells.NumberFormat = "@"

3. 逐行逐列写入数据（替代CopyFromRecordset） #

如果前两种方法仍有问题，直接放弃CopyFromRecordset，循环读取Recordset的每一行每一列写入单元格，确保数据100%保留：

' 替换原有的Copy Data部分代码
Dim rowNum As Long, colNum As Integer
rowNum = 2
Do While Not rs.EOF
    For colNum = 1 To rs.Fields.Count
        destWs.Cells(rowNum, colNum).Value = CStr(rs.Fields(colNum - 1).Value)
    Next colNum
    rs.MoveNext
    rowNum = rowNum + 1
Loop

修正后的完整代码 #

If SheetExists(conn, sheetName) Then
    ' Create a recordset for the sheet
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open "SELECT * FROM [" & sheetName & "]", conn, 3, 1
    
    ' Copy data from the recordset to the new workbook
    Dim destWs As Worksheet
    Set destWs = destWb.Sheets.Add
    'sheetname
    leng = Len(sheetName) - 1
    destWs.Name = Left(sheetName, leng)
    
    ' 先设置所有列为文本格式
    destWs.Cells.NumberFormat = "@"
    
    'Copy header
    For i = 1 To rs.Fields.Count
        destWs.Cells(1, i).Value = rs.Fields(i - 1).Name
    Next i
    
    ' 逐行写入数据，确保完整
    Dim rowNum As Long, colNum As Integer
    rowNum = 2
    Do While Not rs.EOF
        For colNum = 1 To rs.Fields.Count
            destWs.Cells(rowNum, colNum).Value = CStr(rs.Fields(colNum - 1).Value)
        Next colNum
        rs.MoveNext
        rowNum = rowNum + 1
    Loop
    
    ' Close the recordset
    rs.Close
End If

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