如何使用VBA自动修改Excel查询的数据源？

我懂你这个痛点——当把整个文件夹发给别人时，查询直接绑定了你本地的用户路径，导致对方没法连接到他们本地的CSV文件。你已经在尝试用ActiveWorkbook.Path获取路径，方向是对的，只是可能在更新查询数据源的时候没处理到位。

下面给你两种针对性的解决方案，根据你的实际场景选就行：

方案1：修改已存在的查询连接字符串 #

如果你已经创建了查询，只是需要更新它的数据源路径，可以遍历工作簿的连接，替换掉硬编码的旧路径：

Sub UpdateExistingQueryPath()
    Dim csvPath As String
    Dim targetConn As WorkbookConnection
    Dim oldConnString As String
    Dim newConnString As String
    
    ' 获取当前工作簿所在文件夹下的CSV路径
    csvPath = ActiveWorkbook.Path & "\NameOfTheFile.csv"
    
    ' 先检查工作簿是否已保存（未保存的话Path是空的）
    If ActiveWorkbook.Path = "" Then
        MsgBox "请先保存工作簿，否则无法获取相对路径！", vbExclamation
        ActiveWorkbook.SaveAs ' 弹出保存对话框让用户选择位置
        csvPath = ActiveWorkbook.Path & "\NameOfTheFile.csv"
    End If
    
    ' 找到目标查询连接（替换成你实际的连接名称）
    For Each targetConn In ActiveWorkbook.Connections
        If targetConn.Name = "YourQueryConnectionName" Then
            oldConnString = targetConn.OLEDBConnection.Connection
            ' 替换连接字符串里的数据源路径
            ' 这里假设连接字符串格式包含 "Data Source=旧路径"
            Dim pathStart As Integer, pathEnd As Integer
            pathStart = InStr(oldConnString, "Data Source=") + 12
            pathEnd = InStr(pathStart, oldConnString, ";")
            newConnString = Replace(oldConnString, Mid(oldConnString, pathStart, pathEnd - pathStart), csvPath)
            
            ' 更新连接并刷新
            targetConn.OLEDBConnection.Connection = newConnString
            targetConn.Refresh
            Exit For ' 找到目标连接后退出循环
        End If
    Next targetConn
End Sub

方案2：创建查询时直接用动态路径 #

如果是用VBA从头创建查询，那直接在创建阶段就用动态路径，从根源避免硬编码问题：

Sub CreateDynamicCsvQuery()
    Dim csvPath As String
    
    ' 确保工作簿已保存
    If ActiveWorkbook.Path = "" Then
        MsgBox "请先保存工作簿！", vbExclamation
        ActiveWorkbook.SaveAs
    End If
    csvPath = ActiveWorkbook.Path & "\NameOfTheFile.csv"
    
    ' 创建Power Query查询
    ActiveWorkbook.Queries.Add Name:="DynamicCsvQuery", Formula:= _
        "let" & Chr(13) & "" & Chr(10) & _
        "    Source = Csv.Document(File.Contents(""" & csvPath & """),[Delimiter="","", Encoding=1252, QuoteStyle=QuoteStyle.None])," & Chr(13) & "" & Chr(10) & _
        "    #""Promoted Headers"" = Table.PromoteHeaders(Source, [PromoteAllScalars=true])," & Chr(13) & "" & Chr(10) & _
        "    #""Changed Type"" = Table.TransformColumnTypes(#""Promoted Headers"",{{""Column1"", type text}, {""Column2"", Int64.Type}})" & Chr(13) & "" & Chr(10) & _
        "in" & Chr(13) & "" & Chr(10) & "    #""Changed Type"""
    
    ' 将查询加载到工作表（替换成你要加载的工作表和位置）
    ActiveWorkbook.Worksheets("Sheet1").ListObjects.Add(SourceType:=0, Source:= _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=DynamicCsvQuery;Extended Properties=""""" _
        , Destination:=Range("$A$1")).QueryTable.Refresh BackgroundQuery:=False
End Sub

关键提醒 #

• 一定要检查工作簿是否已保存：如果工作簿从未保存过，ActiveWorkbook.Path会返回空字符串，这时候路径拼接就会出错，所以加个判断很有必要。
• 如果你用的是Power Query，其实File.Contents默认会使用相对于当前工作簿的路径（只要工作簿已保存），所以也可以简化成File.Contents("NameOfTheFile.csv")，不过用ActiveWorkbook.Path拼接更直观，避免歧义。

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