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


Muszę wyeksportować tabelę przestawną i jej surowe dane do innego skoroszytu programu Excel. Napisałem tę funkcję, aby to zrobić:
Public Function SaveASSheets (sheetsArray As Variant, destination As String) 
Sheets(sheetsArray).Copy
ActiveWorkbook.SaveAs destination, 50
ActiveWorkbook.Close
End Function

SheetArray to tablica zawierająca arkusze danych źródłowych tabeli przestawnej i tabeli przestawnej
miejsce docelowe to pełna ścieżka, w której chcę nowy plik Excela (ścieżka + dobra nazwa + rozszerzenie (.xlsb))
Problem, na który napotykam podczas wykonywania tego kodu, polega na tym, że nowa tabela przestawna zapisana w nowym pliku w folderze docelowym wskazuje na stare oryginalne dane tabeli przestawnej zamiast używać oryginalnej karty danych, którą skopiowałem razem z nim.
Zakres źródła danych w menedżerze nazw, którego używam dla starej tabeli przestawnej, istnieje w obu plikach (nowym i starym), ale tabela przestawna w nowym pliku wskazuje na zakres źródła danych w starym pliku.
Próbowałem ponownie przypisać nowe źródło danych tabeli przestawnej, ale otrzymałem błąd:

„Program Excel nie może ukończyć tego zadania z dostępnymi zasobami, wybraną mniejszą ilością danych lub zamknął inne aplikacje”.

To jest mój kod:
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

Zaproszony:
Anonimowy użytkownik

Anonimowy użytkownik

Potwierdzenie od:

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
Anonimowy użytkownik

Anonimowy użytkownik

Potwierdzenie od:

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.
Anonimowy użytkownik

Anonimowy użytkownik

Potwierdzenie od:

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

Aby odpowiedzieć na pytania, Zaloguj się lub Zarejestruj się