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

Question

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

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

sheetArray 是一个包含数据透视表和数据透视表源数据工作表的数组
目的地是我想要新 Excel 文件的完整路径(路径 + 精细名称 + 扩展名 (.xlsb))

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

我试图重新分配新的数据透视表数据源，但出现错误:

"Excel cannot complete this task with available resources, Chose less data or close other applications"

这是我的代码:

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

让我们先回顾一下您发布的程序:

这两个过程都使用从事件工作簿复制的一组工作表来创建一个新工作簿。

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

在第二个过程中，您尝试设置 PivotTable.SourceData到程序收到的“输入范围”。它失败，因为应用程序试图在“新工作簿”中创建 PivotCache指向“源工作簿”。但是，即使此操作成功结束，也无法达到目的，因为“输入范围”仍在寻址“源工作簿”。此外，请注意，该过程会关闭工作簿而不保存它，因此如果实现了目标，它将丢失。

还建议始终在所有模块中声明具有此行的变量，这将有助于您实现这一良好做法。

Option Explicit

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



该解决方案提出了两种方法来实现:

目标 :创建一个新工作簿，其中包含来自事件工作簿的一组工作表。此集包含带有 PivotTables 的工作表有一个共同的 SourceData驻留在也包含在集合中的工作表中。

过程参数 :
aShtSrc As Variant包含要包含在新工作簿中的工作表名称的数组
sFullPath As String新工作簿的路径和文件名

方法一 : 将源工作簿中的一组工作表复制到新工作簿中并更改 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

方法二 :将源工作簿复制为新工作簿，然后打开新工作簿并在新工作簿中删除未包含在收到的工作表列表中的工作表。

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