工作簿窗體代碼：

工作簿關閉事件：將添加的數(shù)據(jù)透視表工具欄里面的數(shù)據(jù)透視表下拉菜單刪除,。工作簿存盤。

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
Call menu_del
ActiveWorkbook.Save
Application.DisplayAlerts = True
End Sub

工作簿打開事件：提取數(shù)據(jù)透視表中的SQL語句,，通過調用其他過程提取用到的各個數(shù)據(jù)源的工作簿,，查找帶路徑名稱的工作簿是否存在，不存在的經(jīng)過窗體顯示出來,，點擊窗體中的對應按鈕找到對應的工作簿,，重新指向新的路徑的工作簿，這樣實現(xiàn)當你的數(shù)據(jù)源工作簿給任意移動后通過更新路徑來使數(shù)據(jù)透視表仍然正確工作,。
Private Sub Workbook_Open()
Call menu_add
SqlStr = ActiveSheet.PivotTables("數(shù)據(jù)透視表1").PivotCache.CommandText
Call checkfile
End Sub

模塊2 中的代碼：menu_add是添加菜單事件,；menu_addmsg添加的菜單響應事件,；menu_del刪除菜單事件

Public i%, j%, n%, m%, SqlStr As String
Sub menu_add()
Dim cmb As CommandBarControl
n = Application.CommandBars("PivotTable").Controls("數(shù)據(jù)透視表(&P)").Controls.Count
For i = 1 To n
If Application.CommandBars("PivotTable").Controls("數(shù)據(jù)透視表(&P)").Controls(i).Caption = "查看或修改SQL語句" Then
Exit Sub
End If
Next
Set cmb = Application.CommandBars("PivotTable").Controls("數(shù)據(jù)透視表(&P)").Controls.Add(Type:=msoControlButton)
With cmb
.BeginGroup = True
.Caption = "查看或修改SQL語句"
.OnAction = "menu_addmsg"
.Visible = True
.FaceId = 159
End With
End Sub
Sub menu_addmsg()
UserForm2.Show
End Sub
Sub menu_del()
n = Application.CommandBars("PivotTable").Controls("數(shù)據(jù)透視表(&P)").Controls.Count
For i = 1 To n
If Application.CommandBars("PivotTable").Controls("數(shù)據(jù)透視表(&P)").Controls(i).Caption = "查看或修改SQL語句" Then
Application.CommandBars("PivotTable").Controls("數(shù)據(jù)透視表(&P)").Controls(i).Delete
End If
Next
End Sub

模塊1中：

數(shù)據(jù)透視表刷新事件：
Data Source=" & ThisWorkbook.FullName 。,。 數(shù)據(jù)源指向本工作簿
.Connection 里面的內容指向OLE DB 窗體中的連接
.CommandText = SqlStr 里面的內容指向OLE DB 窗體中的命令文本窗體SQL語句

Sub refreshpv()
With ActiveSheet.PivotTables("數(shù)據(jù)透視表1").PivotCache
       .Connection = Array( _
       "OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;User ID=Admin;Data Source=" & ThisWorkbook.FullName & ";Mode=Share Deny Write;Extended P" _
       , _
       "roperties=""HDR=YES;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engine Type=35;Jet OLEDB:Database Locking" _
       , _
       " Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password="""";Jet OLEDB:Cr" _
       , _
       "eate System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Witho" _
       , "ut Replica Repair=False;Jet OLEDB:SFP=False")
       .CommandType = xlCmdTable
       .CommandText = ""
       .CommandText = SqlStr
End With
ActiveSheet.PivotTables("數(shù)據(jù)透視表1").PivotCache.Refresh
End Sub

獲取那些工作簿已被移動
fnst(j)   獲取SQL語句中用到的工作表對應的工作簿,，含重復工作簿
fls(m) 獲取SQL語句中用到的不重復工作簿
Changenames(m) 獲取那些被移動的工作簿

Function Sql_changefiles(ByVal SqlStr As String) As Variant
Dim fnst(), fls(), Filenames(), Changenames()
n = Len(SqlStr) - Len(Replace(SqlStr, ":", ""))
If n = 0 Then Sql_changefiles = Empty: Exit Function
ReDim fnst(1 To n)
m = 0
For j = 1 To n
       p1 = InStr(p1 + 1, SqlStr, ":")
       p2 = InStr(p1 + 1, SqlStr, ".")
      
       fnst(j) = Mid(SqlStr, p1 - 1, p2 - p1) & ".xls"
Next
For j = 1 To n
       For k = 1 To j - 1
          If fnst(j) = fnst(k) Then GoTo 100
       Next
       ReDim Preserve fls(m)
       fls(m) = fnst(j)
       m = m + 1
100
Next
m = 0
n = UBound(fls)
For i = 0 To n
If Dir(fls(i)) = "" Then
ReDim Preserve Changenames(m)
       Changenames(m) = fls(i)
       m = m + 1
End If
Next
If m = 0 Then Exit Function
Sql_changefiles = Changenames
End Function

檢查文件是否被移動，沒有工作簿被移動就刷新紀錄
如果有工作簿被移動,，用msgbox 讓你做選擇：是,、否、取消3個狀態(tài)

Sub checkfile()
Dim OP, fls()
If Not IsArray(Sql_changefiles(SqlStr)) Then Call refreshpv: Exit Sub
fls = Sql_changefiles(SqlStr)
If UBound(fls) >= 0 Then
OP = MsgBox("源文件已被移走,，請選擇下列選項" + Chr(10) + "1、選擇是,，重新輸入文件全名" + Chr(10) + "2,、選擇否，打開原有的數(shù)據(jù)透視表,數(shù)據(jù)不刷新" + Chr(10) + "3,、選擇取消,，關閉文件", vbYesNoCancel, "Scarlett溫馨提示")
If OP = vbYes Then
       UserForm1.Show
       Exit Sub
End If
If OP = vbNo Then
       Exit Sub
End If

If OP = vbCancel Then
       ActiveWorkbook.Close True
End If
End If
End Sub

用戶窗體1：
定義了一個類 newtpk 用數(shù)組來定義，讓按鈕和textbox做成一對類

Dim newtpk() As 類1
Dim arrmf()

確定按鈕事件實現(xiàn)SQL語句字符串替換功能,，并刷新數(shù)據(jù)透視表
Private Sub CommandButton2_Click()
For i = 0 To UBound(arrmf)
If InStr(Controls("TBox" & i).Value, ".") > 0 Then
' If InStr(Controls("TBox" & i).Value, ".") > 0 And Right(arrmf(i), Len(arrmf(i)) - InStrRev(arrmf(i), "\")) = Right(Controls("TBox" & i).Value, Len(Controls("TBox" & i).Value) - InStrRev(Controls("TBox" & i).Value, "\")) Then
          SqlStr = Replace(SqlStr, Replace(arrmf(i), ".xls", ""), Replace(Controls("TBox" & i).Value, ".xls", ""))
Else
       MsgBox "文件名要帶路徑含后綴的文件名", , "Scarlett_88溫馨提示"
       Controls("TBox" & i).Value = ""
       Controls("TBox" & i).SetFocus
       MsgBox "第" & i + 1 & "文本框不是文件全稱,，點擊右邊按鈕選擇正確的文件", , "信息提示"
       Exit Sub
End If
Next
Call refreshpv
Unload Me
End Sub

退出按鈕關閉窗體
Private Sub CommandButton3_Click()
Unload Me
End Sub

窗體初始化根據(jù)被移動的工作簿個數(shù)添加對應個數(shù)的控件組，并將舊的工作簿名稱顯示在標簽控件中,，對控件的屬性進行設置,，
Private Sub UserForm_Initialize()
Dim Tb As Object
Dim Cb As Object
Dim Lb1 As Object
Dim Lb2 As Object
arrmf = Sql_changefiles(SqlStr)
n = UBound(arrmf)
ReDim newtpk(n)
For i = 0 To n
Set Lb1 = Controls.Add("forms.label.1", "Lbl1" & i, True)
Set Tb = Controls.Add("Forms.textbox.1", "Tbox" & i, True)
Set Cb = Controls.Add("Forms.commandbutton.1", "Combtn" & i, True)
Set Lb2 = Controls.Add("forms.label.1", "Lbl2" & i, True)
Lb1.Move 12, i * 100 + 58, 570, 25
Lb2.Move 12, i * 100 + 110, 66, 18
Tb.Move 78, i * 100 + 110, 510, 25
Cb.Move 588, i * 100 + 110, 12, 27
Set newtpk(i) = New 類1
Set newtpk(i).tbox = Controls("Tbox" & i)
Set newtpk(i).cbn = Controls("Combtn" & i)
Lb1.Caption = "舊文件名：　　" & arrmf(i)
Lb2.Caption = "新文件名"
Tb.Text = ""
Cb.Caption = ""
Lb1.Font.Size = 12
Lb2.Font.Size = 12
Tb.Font.Size = 12
Cb.BackColor = &HC0C0C0
Tb.BackColor = &HE0E0E0
Next
Controls("commandButton2").Top = UBound(arrmf) * 100 + 180
Controls("commandButton3").Top = UBound(arrmf) * 100 + 180
Me.Height = 250 + UBound(arrmf) * 100
End Sub

用戶窗體2：

SqlStr = TextBox1.Text 將窗體中的SQL語句賦值給變量，
經(jīng)過檢查所用的工作簿是否存在后進行刷新數(shù)據(jù)透視表

Private Sub CommandButton1_Click()
SqlStr = TextBox1.Text
Call checkfile
Unload Me
End Sub

Private Sub CommandButton2_Click()
Unload Me
End Sub

窗體初始化時講OLE DB 中的SQL語句賦值給textbox,。
Private Sub UserForm_Initialize()
TextBox1.Text = ActiveSheet.PivotTables("數(shù)據(jù)透視表1").PivotCache.CommandText
End Sub

類模塊中：

定義了兩個類,，一個textbox，一個按鈕
Public WithEvents tbox As MSForms.TextBox
Public WithEvents cbn As MSForms.CommandButton

按鈕類的單擊事件：將選擇的帶路徑的文件名賦值給textbox類
Private Sub cbn_Click()
On Error Resume Next
Dim num%
Dim fopen As FileDialog
Set fopen = Application.FileDialog(msoFileDialogFilePicker)
fopen.Show
If fopen.SelectedItems(1) = "" Then
Exit Sub
Else
tbox.Value = fopen.SelectedItems(1)
Set fopen = Nothing
End If
End Sub







該文件的直接套用說明：
見倒數(shù)第二個圖片：在數(shù)據(jù)透視表下拉有查看或修改SQL語句按鈕,，點擊就會有一個窗體出來,，你可以修改SQL語句，如果連字段都有改變,，則需要你先將所有的字段都拖出透視表,，新的SQL語句就能產(chǎn)生新的數(shù)據(jù)源，重新布局數(shù)據(jù)透視表即可,。因為字段不同,，透視表也就缺省字段，會出錯,。