如何调整ADODB连接代码以完整获取含空首列的Excel数据

问题描述 #

我有一段可正常运行的Select语句，通过GetOpenFilename指定目标工作簿后，能将其中「Data」工作表的数据填充至当前工作表，但部分首单元格为空的列未被导入。请问如何调整以下代码以确保获取所有数据？

原代码 #

Option Explicit
Private Sub main()
Dim Path As String
 Path = Application.GetOpenFilename(Title:="Please select the latest Report", filefilter:="Excel Files(*.xls*),*xls*")
 If Path = "False" Then End
On Error GoTo errhandler:
Dim Conn As Object, Rs As Object, Sql As String

Set Conn = CreateObject("ADODB.Connection")
With Conn
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .ConnectionString = "Data Source=" & Path & ";" & _
    "Extended Properties=""Excel 12.0 Xml;HDR=Yes;IMEX=1"";"
    .Open
     End With
 
 Sql = "SELECT T1.* FROM [Data$A1:AA150000] T1"
 
 Set Rs = Conn.Execute(Sql)
 
 Sheets(1).Cells(2, 1).CopyFromRecordset Rs

 Conn.Close
 Set Conn = Nothing
 Set Rs = Nothing
 End
errhandler:
If Not (Rs Is Nothing) Then
  If (Rs.State And 1) = 1 Then Rs.Close
       Set Rs = Nothing
           End If
MsgBox "Error " & Err.Number & " (" & Err.Description & ")  " & Err.Source
End Sub

问题原因 #

使用ADODB连接Excel时，若设置HDR=Yes，驱动会将第一行识别为表头。如果某列第一行单元格为空，驱动会直接忽略该列，导致数据导入时丢失。IMEX=1仅处理混合数据类型的列，无法解决空表头列被忽略的问题。

解决方案 #

方案1：修改ADODB连接与SQL语句 #

将HDR设为No，让驱动把第一行当作数据行，强制识别所有列，之后手动处理表头：

Option Explicit
Private Sub main()
Dim Path As String
Path = Application.GetOpenFilename(Title:="请选择最新报表", filefilter:="Excel文件(*.xls*),*xls*")
If Path = "False" Then Exit Sub

On Error GoTo errhandler
Dim Conn As Object, Rs As Object, Sql As String
Dim wsTarget As Worksheet
Set wsTarget = Sheets(1)

Set Conn = CreateObject("ADODB.Connection")
With Conn
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    ' 将HDR设为No，第一行作为数据行导入，确保所有列被识别
    .ConnectionString = "Data Source=" & Path & ";" & _
        "Extended Properties=""Excel 12.0 Xml;HDR=No;IMEX=1"";"
    .Open
End With

' 查询整个Data工作表，避免固定范围限制数据获取
Sql = "SELECT * FROM [Data$]"

Set Rs = Conn.Execute(Sql)

' 清空目标工作表原有数据（可选）
wsTarget.Cells.Clear

' 复制原表头（原第一行数据）
wsTarget.Cells(1, 1).CopyFromRecordset Rs
' 移动记录集到下一行，复制剩余数据
Rs.MoveNext
wsTarget.Cells(2, 1).CopyFromRecordset Rs

Conn.Close
Set Conn = Nothing
Set Rs = Nothing
Exit Sub

errhandler:
If Not (Rs Is Nothing) Then
    If (Rs.State And 1) = 1 Then Rs.Close
    Set Rs = Nothing
End If
MsgBox "错误 " & Err.Number & " (" & Err.Description & ")  " & Err.Source
End Sub

方案2：直接使用Excel对象复制数据（更可靠） #

绕过ADODB驱动，直接打开目标工作簿复制数据，完全避免列识别问题：

Option Explicit
Private Sub main()
Dim Path As String
Path = Application.GetOpenFilename(Title:="请选择最新报表", filefilter:="Excel文件(*.xls*),*xls*")
If Path = "False" Then Exit Sub

On Error GoTo errhandler
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim lastRow As Long, lastCol As Long

Set wsTarget = Sheets(1)
' 后台打开源工作簿，不显示界面
Set wbSource = Workbooks.Open(Path, ReadOnly:=True, Visible:=False)
Set wsSource = wbSource.Worksheets("Data")

' 获取源数据的有效范围
lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column

' 清空目标表原有数据（可选）
wsTarget.Cells.Clear

' 复制所有数据到目标表
wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, lastCol)).Copy _
    Destination:=wsTarget.Cells(1, 1)

' 关闭源工作簿，不保存修改
wbSource.Close SaveChanges:=False

Set wsSource = Nothing
Set wbSource = Nothing
Set wsTarget = Nothing
Exit Sub

errhandler:
If Not wbSource Is Nothing Then
    wbSource.Close SaveChanges:=False
End If
MsgBox "错误 " & Err.Number & " (" & Err.Description & ")  " & Err.Source
End Sub

说明 #

• 方案1仍使用ADODB，适合需要用SQL筛选数据的场景；
• 方案2直接复制数据，兼容性更好，不会出现列丢失问题，适合单纯导入全量数据的场景。

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