Eksportuj tabelę przestawną i dane źródłowe do innego skoroszytu

Przyjrzyjmy się procedurom, które opublikowałeś jako pierwsze:
Obie procedury tworzą nowy skoroszyt przy użyciu grupy arkuszy skopiowanych z aktywnego skoroszytu.
Obiekty w skopiowanych arkuszach zachowują wszystkie swoje oryginalne właściwości, w tym

PivotTable.SourceData

, więc skopiowane

PivotTables

nadal wskazują „źródłowy skoroszyt”.
W drugiej procedurze próbujesz ustawić

PivotTable.SourceData

na „Zakres wejściowy” otrzymany przez procedurę. Nie udaje się, ponieważ aplikacja próbuje utworzyć w „Nowym skoroszycie”

PivotCache

wskazujący na „Source Workbook”. Jednak nawet jeśli ta operacja się powiedzie, nie osiągnie celu, ponieważ „Zakres wejściowy” nadal odnosi się do „Źródłowego skoroszytu”. Zwróć również uwagę, że procedura zamyka skoroszyt bez zapisywania go, więc jeśli cel zostanie osiągnięty, zostanie on utracony.
Zasugeruj również, aby zawsze deklarować zmienne, które mają ten ciąg we wszystkich modułach, aby pomóc Ci w tej dobrej praktyce.

Option Explicit

Może być częścią standardowych ustawień VBA. Z menu aplikacji Excel VBA wybierz:

Narzędzia \ Opcje

w zakładce okna dialogowego: edytor zaznacz opcję „Wymagaj deklaracji zmiennej”
https://i.stack.imgur.com/EiiN6.pngTo rozwiązanie oferuje dwie metody osiągnięcia

:

cel, powód
: Utwórz nowy skoroszyt zawierający zestaw arkuszy z aktywnego skoroszytu. Ten zestaw zawiera arkusze z

PivotTables

współużytkującymi wspólne

SourceData

, które można znaleźć na arkuszu również zawartym w zestawie.

Argumenty procedury

:

aShtSrc

As Variant

tablica zawierająca nazwy arkuszy, które mają zostać uwzględnione w nowym skoroszycie

sFullPath

As String

ścieżka i nazwa pliku nowej książki

• Metoda 1 : Skopiuj zestaw arkuszy z oryginalnego skoroszytu do nowego skoroszytu i zmień

  PivotTables

  w nowym skoroszycie na nowy

  PivotCache

  wskazujący na

  DataSource

  w nowym skoroszycie.

  Sub Ptb_Copy_To_NewWbk_And_Change_DataSource(aShtSrc As Variant, sFullPath As String)Dim WbkSrc As Workbook, WbkNew As WorkbookDim Wsh As Worksheet, Pch As PivotCache, Ptb As PivotTableDim sPtbSrc As StringDim blPtDone As BooleanDim 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 = TrueEnd Sub

• Metoda 2 : Skopiuj oryginalny skoroszyt jako nowy skoroszyt, a następnie otwórz nowy skoroszyt i usuń arkusze z nowego skoroszytu, które nie znajdują się na liście otrzymanych arkuszy.

  Sub Wbk_Copy_To_NewWbk_SelectedSheets(aShtSrc As Variant, sFullPath As String)Dim WbkSrc As Workbook, WbkNew As WorkbookDim Wsh As WorksheetDim blShtDelete As BooleanDim vItm As VariantDim blAppDisplayAlerts As BooleanRem Set Application PropertiesblAppDisplayAlerts = Application.DisplayAlertsApplication.ScreenUpdating = FalseApplication.EnableEvents = FalseRem Set Source WorkbookSet WbkSrc = ThisWorkbookRem Save as New WorkbookWbkSrc.SaveCopyAs (sFullPath)Rem Open New WorkbookSet WbkNew = Workbooks.Open(sFullPath)Rem Delete Other Worksheets in New WorkbookFor 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.DeleteNextRem Save & Close New WorkbbokWbkNew.Close SaveChanges:=TrueWbkSrc.ActivateRem Set Application PropertiesApplication.DisplayAlerts = blAppDisplayAlertsApplication.ScreenUpdating = TrueApplication.EnableEvents = TrueEnd Sub

Znalazłem rozwiązanie, które tworzy kopię całego arkusza kalkulacyjnego w nowej lokalizacji i usuwa niepotrzebne zakładki
To jest funkcja:

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.CloseEnd Function

Wiem, że to niezbyt dobre rozwiązanie, ale działa.

Jeśli kopiujesz zarówno tabelę przestawną, jak i źródło, dlaczego nie zaktualizować źródła tabeli przestawnej w nowej książce, aby pasowało do źródła starej. Zakładając, że nazwa arkusza jest taka sama, użyj poniższego kodu.

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