Let’s first review the procedures you posted:
Both procedures create a new workbook using a group of worksheets copied from the active workbook.
The objects in the copied worksheets retain all their original properties, PivotTable.SourceData among them, so the PivotTables copied are still pointing to the “source workbook”.
In the second procedure your attempt to set the PivotTable.SourceData to the “Input Range” recieved by the procedure. It fails as the application is trying to create in the “New Workbook” a PivotCache pointing to the “Source Workbook”. However, even if this operation ends successfully, it will not achieve its purpose as the “Input Range” is still addressing the “Source Workbook”. Additionally, note that the procedure closes the workbook without saving it, so if the objective was achieved it would have been lost.
Suggest also to always declare the variables having this line in all modules will assist you with this good practice.
Option Explicit
It can be part of the standard VBA settings. In the Excel VBA application menu select: Tools\Options in the dialog box tab: Editor, check the “Require Variable Declaration” option
This solution propose two methods to achieve the:
Objective: Create a new workbook containing a set of worksheets from the active workbook. This set contains worksheets with PivotTables having a common SourceData that resides in a worksheet also included in the set.
Procedures arguments:
aShtSrc As Variant Array containing the names of the worksheets to be included in the new workbook
sFullPath As String Path and Filename of the new workbook
Method 1: Copy set of worksheets from source workbook into a new workbook and change PivotTables in new workbook to a new PivotCache pointing to the DataSource in the new workbook.
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
Method 2: Copy source workbook as new workbook, then open new workbook and delete in new workbook the worksheets not included in list of worksheets received.
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
