VBA通过文件选择器生成带固定工作表和区域的透视表数据源路径

核心修改点 #

• 补充文件未选中时的提前退出逻辑，避免后续代码异常执行
• 新增源文件工作表校验逻辑，若选中文件不含「new rates」工作表直接提示终止
• 自动拼接符合要求的透视表数据源路径，固定引用「new rates」工作表A:AP列范围
• 新增源文件自动关闭逻辑，操作完成后不残留多余打开的文件窗口

完整代码 #

Sub PivotSource()
    Dim ws As Worksheet, pivot As PivotTable, cache As PivotCache
    Dim FileToOpen As Variant, OpenBook As Workbook
    Dim sourceSht As Worksheet, sourceStr As String
    
    FileToOpen = Application.GetOpenFilename(Title:="请选择透视表数据源文件", MultiSelect:=False, FileFilter:="Excel Files(*.xls*),*xls*")
    If FileToOpen <> False Then
        Set OpenBook = Application.Workbooks.Open(FileToOpen)
    Else
        MsgBox "未选中任何文件，操作终止"
        Exit Sub
    End If
    
    ' 校验源文件是否存在指定工作表
    On Error Resume Next
    Set sourceSht = OpenBook.Worksheets("new rates")
    On Error GoTo 0
    If sourceSht Is Nothing Then
        MsgBox "选中的文件中不存在「new rates」工作表，操作终止"
        OpenBook.Close SaveChanges:=False
        Exit Sub
    End If
         
    MsgBox "工作簿已打开，正在更新数据源...", vbInformation
    
    ' 拼接符合要求的数据源路径
    sourceStr = "'" & Left(OpenBook.FullName, Len(OpenBook.FullName) - Len(OpenBook.Name)) & "[" & OpenBook.Name & "]new rates'!R2C1:R1048576C42"
    
    ThisWorkbook.Activate
    Set cache = ThisWorkbook.PivotCaches.Create(XlPivotTableSourceType.xlDatabase, SourceData:=sourceStr)
    
    For Each ws In ThisWorkbook.Worksheets
        For Each pivot In ws.PivotTables
            If cache.Index > 0 Then
                pivot.CacheIndex = cache.Index
            Else
                pivot.ChangePivotCache cache
            End If
        Next
    Next

    cache.Refresh
    
    ' 关闭打开的源文件，不保存修改
    OpenBook.Close SaveChanges:=False
    
    MsgBox "所有数据透视表数据源已更新完成", vbInformation
    
End Sub

关键逻辑说明 #

拼接数据源字符串时，自动拆分选中文件的存储路径和文件名，按照透视表要求的格式组合，固定引用new rates工作表的A到AP列全量数据，无需手动调整路径格式。

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