将数据透视表和源数据导出到另一个工作簿

我需要将数据透视表及其源数据导出到另一个Excel工作簿。 我已经写了这个function来做到这一点：

Public Function SaveASSheets (sheetsArray As Variant, destination As String) Sheets(sheetsArray).Copy ActiveWorkbook.SaveAs destination, 50 ActiveWorkbook.Close End Function 

sheetsArray是一个数据透视表和数据透视表源数据工作表的数组目的地是一个完整的path，我想新的Excel文件（path+罚款名称+扩展名（.xlsb））

我执行此代码时遇到的问题是保存在目标文件夹中的新文件中的新数据透视表指向旧的数据透视表源数据，而不是使用已复制的源数据选项卡。 名称pipe理器中用于旧数据透视表的数据源范围存在于两个文件（新的和旧的）中，但是新文件中的数据透视表指向旧文件中的数据源范围。

我试图重新分配新的数据透视表数据源，但我得到一个错误：

“Excel无法用可用资源完成此任务，select较less数据或closures其他应用程序”

这是我的代码：

 Public Function SaveASSheets(sheetsArray As Variant, destination As String, Optional pivotTableRange As Range) Sheets(sheetsArray).Copy ActiveWorkbook.SaveAs destination, 50 For Each Sheet In ActiveWorkbook.Worksheets For Each Pivot In Sheet.PivotTables If Not pivotTableRange Is Nothing Then Pivot.SourceData = pivotTableRange End If Pivot.RefreshTable Pivot.Update Next Next ActiveWorkbook.Close End Function 

Answer 1

我们先来看看你发布的程序：

这两个过程使用从活动工作簿复制的一组工作表创build一个新的工作簿。

复制的工作表中的对象保留其所有的原始属性，其中PivotTable.SourceData ，所以复制的PivotTables表仍然指向“源工作簿”。

在第二个过程中，尝试将PivotTable.SourceData设置为过程接收的“input范围”。 由于应用程序试图在“新工作簿”中创build指向“源工作簿”的数据PivotCache因此失败。 但是，即使该操作成功结束，由于“input范围”仍然针对“源工作簿”，所以不能达到其目的。 此外，请注意，该过程将closures工作簿而不保存，所以如果达到目标，将会丢失。

build议在所有模块中始终声明variables具有这一行，这将有助于您采取这一良好做法。

 Option Explicit 

它可以是标准VBA设置的一部分。 在Excel VBA应用程序菜单中select： Tools\Options ，在对话框选项卡：编辑器中，选中“需要variables声明”选项

该解决scheme提出了两种方法来实现：

目标 ：创build一个包含活动工作簿中一组工作表的新工作簿。 此集包含工作表与PivotTables表有一个共同的SourceData驻留在工作表中也包含在该集。

程序参数 ：

aShtSrc As Variant包含要包含在新工作簿中的工作表名称的数组

sFullPath As String新的工作簿的As Stringpath和文件名

• 方法1 ：将源工作簿中的工作表集合复制到新的工作簿中，并将新工作簿中的PivotTables表更改为指向新工作簿中的DataSource的新PivotCache 。

   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 

Answer 2

我find了一个解决scheme，使整个电子表格的副本在新的位置，并删除不必要的选项卡

这是function：

 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 

我知道这不是很好的解决scheme，但它的工作原理。

Answer 3

如果要复制数据透视表和数据源，那么为什么不更新新工作簿中数据透视表的来源以便与旧数据库的数据库相匹配。 假设您的表单命名是相同的，请使用下面的代码。

 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