如何绕过手动输入路径，未保存工作簿时运行VBA ADO Recordset宏？

方案1：改进ADO连接，自动获取已打开工作簿的完整路径 #

如果目标工作簿已经保存过，可以直接通过Workbooks对象的FullName属性获取完整路径，完全替代手动输入的单元格路径。

修改后的GetQueryResults2代码：

Sub GetQueryResults2(SQLV6Retail As String)
    '==============================='
    'This is for V6 data tab bringing data from retail workbook report
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim ws As Worksheet
    Dim LO As ListObject
    Dim targetWb As Workbook
    
    ' 定位目标工作簿
    Set targetWb = Workbooks("PMWEB_BOA_Projects.xlsm")
    Set LO = targetWb.Worksheets("Assigned projects - RETAIL").ListObjects("Assigned")
    
    ' 清除筛选
    LO.AutoFilter.ShowAllData

    Set cn = New ADODB.Connection
    ' 直接用已打开工作簿的FullName作为数据源，无需手动输入路径
    cn.Mode = adModeRead
    cn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & targetWb.FullName & ";" & _
        "Extended Properties='Excel 12.0 Macro;HDR=YES;IMEX=1';"

    cn.Open

    Set rs = New ADODB.Recordset
    rs.ActiveConnection = cn
    rs.Source = SQLV6Retail
    rs.Open

    ' 写入数据到目标工作表
    Set ws = targetWb.Sheets("Assigned Projects - RETAIL")
    ws.Range("A2").CopyFromRecordset rs

    rs.Close
    cn.Close
End Sub

修改要点 #

• 移除读取单元格路径的冗余代码，直接通过targetWb.FullName自动获取已打开工作簿的完整路径
• 明确目标工作簿的引用，避免ThisWorkbook与目标工作簿的混淆问题

方案2：改用Excel对象模型筛选数据（支持未保存的工作簿） #

如果目标工作簿未保存过，ADO驱动无法访问无磁盘路径的文件，此时直接用Excel自带的筛选功能处理更可靠，无需依赖ADO连接。

修改后的代码（替换原GetQueryResults2和filterboa_Click逻辑）：

Private Sub filterboa_Click()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Dim BOARetail As String
    Dim targetWb As Workbook
    Dim sourceWs As Worksheet
    Dim targetWs As Worksheet
    Dim lastRow As Long
    Dim sourceRange As Range
    Dim filteredRange As Range
    
    ' 定位目标工作簿和工作表
    Set targetWb = Workbooks("PMWEB_BOA_Projects.xlsm")
    Set sourceWs = targetWb.Sheets("V6 data")
    Set targetWs = targetWb.Sheets("Assigned projects - RETAIL")
    
    ' 清除目标区域旧数据
    lastRow = targetWs.Range("A" & targetWs.Rows.Count).End(xlUp).Row
    If lastRow >= 2 Then
        targetWs.Range("A2:AK" & lastRow).ClearContents
    End If
    
    ' 获取筛选条件
    BOARetail = ListBox1.Value
    If BOARetail = "" Then
        MsgBox "请选择筛选的用户名", vbExclamation
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Exit Sub
    End If
    
    ' 清除源表旧筛选
    sourceWs.AutoFilterMode = False
    
    ' 筛选数据："Project Coordinator or BOA"列对应第6列（根据SQL字段顺序）
    lastRow = sourceWs.Range("A" & sourceWs.Rows.Count).End(xlUp).Row
    Set sourceRange = sourceWs.Range("A1:AK" & lastRow)
    sourceRange.AutoFilter Field:=6, Criteria1:=BOARetail
    
    ' 复制筛选后的数据（跳过表头）
    On Error Resume Next
    Set filteredRange = sourceRange.Offset(1).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If Not filteredRange Is Nothing Then
        filteredRange.Copy targetWs.Range("A2")
    End If
    
    ' 清除筛选
    sourceWs.AutoFilterMode = False
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

修改要点 #

• 完全移除ADO相关代码，直接用Excel原生AutoFilter功能筛选数据
• 无需依赖工作簿的磁盘路径，不管工作簿是否保存都能正常运行
• 避免了ADO连接的潜在问题（如驱动版本兼容、文件锁定等）

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