使用ADODB.Connection从关闭文件提取单元格数据的宏仅在文件打开时生效

核心问题排查方向及修复方案 #

• 连接字符串格式错误
  你的连接字符串存在两个潜在问题：一是未处理带空格的文件路径，二是Extended Properties的引号嵌套不规范，另外如果目标文件是旧版.xls格式，Excel 12.0 Xml的标识也不适用。
  修改为以下兼容格式（支持带空格路径、.xlsx/.xls文件，避免数据类型读取异常）：

  cn.ConnectionString = _
  "Provider=Microsoft.ACE.OLEDB.12.0;" & _
  "Data Source=""" & GetFile & """;" & _
  "Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";"
  

  说明：

  • 用三重引号包裹文件路径，解决空格导致的连接失败
  • IMEX=1强制将单元格内的混合数据类型转为文本，避免读取时跳过异常数据
  • 若目标文件是.xls，把Excel 12.0替换为Excel 8.0

• 未处理取消选择文件的场景
  如果用户在文件选择对话框点击取消，GetFile会是空字符串，后续执行cn.Open必然报错。添加判断逻辑：

  NextCode:
      GetFile = sItem
      Set file = Nothing
  
      ' 未选文件直接退出，避免后续报错
      If GetFile = "" Then Exit Sub
  
      Sheet1.Range("A1").CurrentRegion.Offset(1, 0).Clear
  

• 工作表名称或状态问题
  确认目标文件的工作表确实叫Sheet1——注意如果工作表名有空格或特殊字符，要在SQL语句中用[工作表名$单元格范围]的格式（比如[旅行申请单$J14:J14]）。另外，ADODB无法读取隐藏的工作表，需要确保目标工作表处于可见状态。

• ADODB驱动兼容性问题
  64位Office需要安装64位的Microsoft Access Database Engine驱动，32位Office对应32位驱动。如果驱动缺失或版本不匹配，会导致无法连接关闭的Excel文件。

• 添加错误捕获定位具体问题
  原代码没有错误处理，无法知道具体报错信息。添加错误捕获模块，能直接看到错误代码和描述：

  ' 在代码开头添加
  On Error GoTo ErrorHandler
  
  ' 在代码末尾添加
  Cleanup:
      ' 确保资源释放
      If Not rs Is Nothing Then
          If rs.State = adOpen Then rs.Close
          Set rs = Nothing
      End If
      If Not cn Is Nothing Then
          If cn.State = adStateOpen Then cn.Close
          Set cn = Nothing
      End If
      Exit Sub
  
  ErrorHandler:
      MsgBox "错误代码：" & Err.Number & vbCrLf & "错误信息：" & Err.Description
      Resume Cleanup
  

完整修复后的代码 #

Sub ImportDataFromFinishedTravelRequest()
    On Error GoTo ErrorHandler
    Dim cn As ADODB.Connection
    Dim file As FileDialog
    Dim sItem As String
    Dim GetFile As String
    Dim rs As ADODB.Recordset
    Dim unusedRow As Long
    
    ' 获取主表下一个空行
    With Sheets("Sheet1")
        unusedRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
    End With
    
    ' 选择目标文件
    Set file = Application.FileDialog(msoFileDialogFilePicker)
    With file
        .Title = "选择文件"
        .AllowMultiSelect = False
        '.InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFile = sItem
    Set file = Nothing

    ' 未选择文件直接退出
    If GetFile = "" Then Exit Sub

    ' 清空主表已有数据（保留表头）
    Sheet1.Range("A1").CurrentRegion.Offset(1, 0).Clear

    Set cn = New ADODB.Connection

    ' 兼容型连接字符串
    cn.ConnectionString = _
    "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=""" & GetFile & """;" & _
    "Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";"

    cn.Open
    
        ' 读取目标单元格数据
        Set rs = New ADODB.Recordset
    
        rs.ActiveConnection = cn
        rs.Source = "SELECT * FROM [Sheet1$J14:J14]"
        rs.Open
    
        ' 将数据写入主表
        Sheet1.Range("A" & unusedRow).CopyFromRecordset rs
       
        rs.Close

Cleanup:
    ' 释放资源
    If Not rs Is Nothing Then
        If rs.State = adOpen Then rs.Close
        Set rs = Nothing
    End If
    If Not cn Is Nothing Then
        If cn.State = adStateOpen Then cn.Close
        Set cn = Nothing
    End If
    Exit Sub

ErrorHandler:
    MsgBox "错误代码：" & Err.Number & vbCrLf & "错误信息：" & Err.Description
    Resume Cleanup
End Sub

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