Question

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

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

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

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

我尝试重新分配新的数据透视表数据源，但出现了错误：

“Excel无法使用可用资源完成此任务，选择较少的数据或关闭其他应用程序”

这是我的代码：

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新工作簿的路径和文件名

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

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

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

Answer 2

我找到了一个解决方案，可以在新位置复制整个电子表格并删除不必要的标签

这是功能：

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

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

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

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

3 个答案: