出口 Pivot Table 和另一个工作簿的源数据

让我们首先考虑您发布的程序：

这两种过程使用从活动本书复制的一组表格创建了一本新书。

复制纸张中的对象保留所有原始属性，包括

PivotTable.SourceData

, 因此，复制

PivotTables

仍然表明 “source workbook”.

在第二个程序中，您试图建立

PivotTable.SourceData

在 “Input Range”, 通过程序获得。 他失败了，因为应用程序正在尝试创建 “New Workbook” a

PivotCache

, 表明 “Source Workbook”. 但是，即使这个操作成功完成，它也不会达到目标，因为 “Input Range” 仍然有吸引力 “Source Workbook”. 另外，请注意，该程序关闭书而不保存它，因此，如果实现目标，则会丢失。

建议还始终声明所有模块中具有此字符串的变量，这将在这种良好的练习中帮助您。

Option Explicit

它可以是标准设置的一部分。 VBA. 在应用程序菜单中 Excel VBA 选择：

Tools\Options

在对话框选项卡上：编辑器选中框 “Require Variable Declaration”

https://i.stack.imgur.com/EiiN6.png
该决定提供了两种实现的方法。

:

目的

: 创建一个来自活动工作书中的一组表格的新工作簿。 这个套件包含床单

PivotTables

, 有共同点

SourceData

, 在纸上，也包括在集合中。

程序论据

:

aShtSrc

As Variant

包含将包含在新工作簿中的表名的数组。

sFullPath

As String

新书文件的路径和名称


方法 1

: 将一组从源书中复制到一本新书并更改

PivotTables

在新书上的新书

PivotCache

, 表明

DataSource

在一本新书。

Sub Ptb_Copy_To_NewWbk_And_Change_DataSource/aShtSrc As Variant, sFullPath As String/

Dim WbkSrc As Workbook, WbkNew As Workbook

Dim Wsh As Worksheet, Pch As PivotCache, Ptb As PivotTable

Dim sPtbSrc As String

Dim blPtDone As Boolean

Dim blAppDisplayAlerts As Boolean



 Rem Set Application Properties

 blAppDisplayAlerts = Application.DisplayAlerts

 Application.ScreenUpdating = False

 Application.EnableEvents = False



 Rem Set Source Workbook

 Set WbkSrc = ThisWorkbook



 Rem Get PivotTable Source Data

 sPtbSrc = Empty

 For Each Wsh In WbkSrc.Worksheets/aShtSrc/

 On Error Resume Next

 sPtbSrc = Wsh.PivotTables/1/.SourceData

 On Error GoTo 0

 If sPtbSrc <> Empty Then Exit For

 Next



 Rem Copy Sheets to Create New Workbook

 WbkSrc.Sheets/aShtSrc/.Copy

 Set WbkNew = ActiveWorkbook



 Rem Save New Workbook /overwrites existing workbook/

 Application.DisplayAlerts = 0

 WbkNew.SaveAs Filename:=sFullPath, FileFormat:=xlExcel12

 Application.DisplayAlerts = 1



 Rem Create PivotCache in New Workbook

 Set Pch = WbkNew.PivotCaches.Create/ _

 SourceType:=xlDatabase, _

 SourceData:=sPtbSrc, _

 Version:=xlPivotTableVersion15/



 Rem Change PivotCache to 1st PivotTable in New Workbook

 For Each Wsh In WbkNew.Worksheets

 For Each Ptb In Wsh.PivotTables

 Ptb.ChangePivotCache Pch

 blPtDone = True

 Exit For

 Next

 If blPtDone Then Exit For

 Next



 Rem Change PivotCache to Reamining PivotTables in New Workbook

 For Each Wsh In WbkNew.Worksheets

 For Each Ptb In Wsh.PivotTables

 Ptb.CacheIndex = Pch.Index

 Next: Next



 Rem Refresh PivotTables, Save & Close New Workbbok

 Pch.Refresh

 WbkNew.Close SaveChanges:=True

 WbkSrc.Activate



 Rem Set Application Properties

 Application.DisplayAlerts = blAppDisplayAlerts

 Application.ScreenUpdating = True

 Application.EnableEvents = True



End Sub

方法 2

: 将原图复制为新书，然后在收到的纸张列表中打开一本新书并删除未包含在未包含的新书中。

Sub Wbk_Copy_To_NewWbk_SelectedSheets/aShtSrc As Variant, sFullPath As String/

Dim WbkSrc As Workbook, WbkNew As Workbook

Dim Wsh As Worksheet

Dim blShtDelete As Boolean

Dim vItm As Variant

Dim blAppDisplayAlerts As Boolean



Rem Set Application Properties

blAppDisplayAlerts = Application.DisplayAlerts

Application.ScreenUpdating = False

Application.EnableEvents = False



Rem Set Source Workbook

Set WbkSrc = ThisWorkbook



Rem Save as New Workbook

WbkSrc.SaveCopyAs /sFullPath/



Rem Open New Workbook

Set WbkNew = Workbooks.Open/sFullPath/



Rem Delete Other Worksheets in New Workbook

For Each Wsh In WbkNew.Worksheets

 blShtDelete = True

 For Each vItm In aShtSrc

 If Wsh.Name = vItm Then

 blShtDelete = False

 Exit For

 End If: Next

 If blShtDelete Then Wsh.Delete

Next



Rem Save & Close New Workbbok

WbkNew.Close SaveChanges:=True

WbkSrc.Activate



Rem Set Application Properties

Application.DisplayAlerts = blAppDisplayAlerts

Application.ScreenUpdating = True

Application.EnableEvents = True



End Sub

我找到了一个解决方案，它在一个新的地方制作了整个电子表格的副本，并删除了不必要的标签。

这是一个功能：

Public Function SaveASSheets/sheetsArray As Variant, destination As String/



 ActiveWorkbook.Sheets.Copy

 ActiveWorkbook.SaveAs destination, 50

 For Each Sheet In ActiveWorkbook.Worksheets

 doNotDelete = False

 For Each element In sheetsArray

 If element = Sheet.Name Then

 doNotDelete = True

 End If

 Next

 If Not doNotDelete Then

 Application.DisplayAlerts = False

 Sheet.Delete

 Application.DisplayAlerts = True

 End If

 Next

 ActiveWorkbook.Save

 ActiveWorkbook.Close



End Function

我知道这不是一个好的解决方案，但它有效。

如果你复制和 pivot table, 和来源，为什么不更新来源 pivot table 在新书中，使它对应于旧的来源。 假设您的工作表名匹配，请使用下面的代码。

WkShtIndex = 0

For Each WkSht In NewWB.Worksheets

 WkShtIndex = WkShtIndex + 1

 PTIndex = 0

 For Each PTable In WkSht.PivotTables

 PTIndex = PTIndex + 1

 PTable.SourceData = MasterWkBk.Sheets/NewWB.Worksheets/WkShtIndex/.Name/.PivotTables/PTIndex/.SourceData

 PTable.RefreshTable

 Next PTable

Next WkSht