Excel: печать всех фильтров на сводной таблице

Question

Итак, у меня есть сводная таблица, которую я назвал «CSRTable», потому что я не создан.В этой сводной таблице есть график продаж для каждого представителя (поле с именем csr_name) за набор недель (поле с именем WeekEnding)

Вот сводная таблица, данные извлекаются из вкладки "Sale Raw ", который является Sheet3 в VBA:

Так что это моя простая сводная таблица.В чем проблема, мой босс выдал мне директиву: распечатать один раз, и он напечатает ВСЕ наши "csr_name" для данного WeekEnding.

Я не знаю, как это сделать, я знаю, что есть способдля VBA, но я не нашел способ, которым я был в состоянии работать, это только один, который я нашел:

Sub LoopField()
Dim pivF As PivotField
Dim pivI As PivotItem

Set pivF = ActiveSheet.PivotTables("CSRPivot").PivotFields("csr_name")
Application.ScreenUpdating = False
For Each pivI In pivF.PivotItems
    pivF.CurrentPage = pivI.Name

    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
Next pivI
 'Clear filer
pivF.ClearAllFilters

Application.ScreenUpdating = True
End Sub

Но это не работает, он просто печатаетодин (в данном случае Асеведо).

Итак, он хочет изменить CSR_NAME, но не WeekEnding, и напечатать каждый из них на отдельной странице.Если VBA случайно верна, вот где она находится, когда я выбираю сводную таблицу и нажимаю Alt + F11

За QHarr Iиметь в комментариях

Option Explicit
'Requires all items selected
Sub GetAllCSRItems()
    Const filePath As String = "C:\Users\User\Desktop\" 'save location for new files
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim pvt As PivotTable
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Sheet2")
    Set pvt = ws.PivotTables("CSRPivot")
    Application.ScreenUpdating = False
    Dim pvtField As PivotField
    Dim item As Variant
    Set pvtField = pvt.PivotFields("csr_name")
    pvtField.ClearAllFilters
    pvtField.CurrentPage = "(All)"

     For Each item In pvtField.PivotItems
        item.Visible = True
     Next item
    pvt.ShowPages "csr_name"
    For Each item In pvtField.PivotItems
        Dim newBook As Workbook
        Set newBook = Workbooks.Add
        With newBook
            .Worksheets(1).Name = item.Name
            wb.Worksheets(item.Name).UsedRange.Copy
            Worksheets(item.Name).Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
           .SaveAs Filename:=filePath & item.Name & ".xlsx"
           .Close
        End With
        Set newBook = Nothing
Next item
    Application.DisplayAlerts = False
    For Each item In pvtField.PivotItems
         wb.Worksheets(item.Name).Delete
    Next item
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

в

и все еще ничего не получил от этого результата

Answer 1

Я проверил, и вы сможете сделать что-то вроде следующего.

Примечание:

Мы экспортируем лист, который содержит сводную диаграмму, как это выглядитлучший размер мудрый в PDF.Кроме того, у нас есть дополнительная подпрограмма для избавления от сгенерированных PDF-файлов, которые можно вызывать отдельно.

---

Код

Option Explicit

Const filePath As String = "C:\Users\User\Desktop\FolderToEmpty\"

Public Sub GetAllEmployeeSelections()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim pvt As PivotTable

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Print THIS TAB")
    Set pvt = ws.PivotTables("CSRPivot")

    ws.PageSetup.Orientation = xlLandscape
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim pvtField As PivotField
    Dim item As Long, item2 As Long

    Set pvtField = pvt.PivotFields("csr_name")

    For item = 1 To pvtField.PivotItems.Count

          pvtField.PivotItems(item).Visible = True

          For item2 = 1 To pvtField.PivotItems.Count

              If item2 <> item Then pvtField.PivotItems(item2).Visible = False

          Next item2

          ws.ExportAsFixedFormat Type:=xlTypePDF, FILENAME:=filePath & Application.WorksheetFunction.Clean(Replace(pvtField.PivotItems(item).Name, ";", "_")) & ".pdf", Quality:=xlQualityStandard, _
                                                                   IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

    Next item

    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic

End Sub

Public Sub ClearFolder()
    Dim f As Object, fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FolderExists(Left$(filePath, Len(filePath) - 1)) Then
        For Each f In fso.GetFolder(Left$(filePath, Len(filePath) - 1)).Files
            f.Delete Force:=True
        Next f
    End If
End Sub