用VBA修改所有透视表的数据源

问题描述：

在资源管理器里复制Excel文件，如A文件：商品报表.xlsx复制为B文件：商品报表 - 副本.xlsx，其中A文件中有很多透视表。这时B文件中的透视表的数据源居然变成了'[商品报表.xlsx]Sheet1'!$A$1:$Q$1501，自动添加了A文档的绝对路径！透视表的数据源并不指向B文件本身！当文件中有大量透视表的时候，一个个的修改透视表的数据源简直要崩溃。。。从2013年就有人向微软反应了这个问题，但至今没有解决。试验下来只有两个办法：

1. 在建立透视表的时候，勾选将此数据添加到数据模型

2. 用VBA自动更新所有透视表的数据源

Public Sub Update_PivotTables_Source()

Dim currWS As Worksheet

Dim currPT As PivotTable

Dim strName As String

Dim strMsg As String

Dim Res

On Error Resume Next

Filename = ThisWorkbook.Sheets("修改数据源").Cells(3, 3)

Workbooks.Open (Filename)

For Each currWS In Application.Worksheets

    For Each currPT In currWS.PivotTables

        currPT.SourceData = CutFilename(currPT.SourceData)

        currPT.RefreshTable

    Next currPT

Next currWS

MsgBox "所有透视表数据源更新完毕！"

End Sub

Private Function CutFilename(strSource As String) As String

Dim intPosition As Integer

Dim intStrLen As Integer

Dim blnFound As Boolean

Dim intFileStart As Integer

Dim intFileEnd As Integer

Dim chrCurr As String

strSource = Trim(strSource)

CutFilename = strSource

intPosition = 0: intStrLen = Len(strSource)

intFileStart = 0: intFileEnd = 0

blnFound = False

Do While (Not (blnFound) And (intPosition < intStrLen))

    intPosition = intPosition + 1

    chrCurr = Mid(strSource, intPosition, 1)

    Select Case chrCurr

        Case "["

            intFileStart = intPosition

        Case "]"

            intFileEnd = intPosition

            blnFound = True

    End Select

Loop

If blnFound Then CutFilename = Mid(strSource, 1, intFileStart - 1) & Mid(strSource, intFileEnd + 1, intStrLen)

End Function