Excel VBA导出数据透视表

Question

the workbook: In my workbook the user completes a table with data. When clicking a command button the VBA code (see below) updates a PivotTable on another worksheet and then splits this table into different worksheets based on the different values filled in the pivotfield " Monstertype " (each pivotitem in that pivotfield becomes a new sheet with that table). These sheets are later transferred to a word document.

The problem: On the first trial the first pivotitem to encounter was called "Hygiene control", it then worked fine. On later trials it keeps looking for the pivotitem "Hygiene control" even if its not there anymore, with as a result I receive the error that it falls outside the subscript.

Sub exportPivot()
Application.ScreenUpdating = False

Worksheets("Blad9").PivotTables("Draaitabel17").RefreshTable

Dim wbbron As Workbook
Dim wbdoel As Workbook

Dim shtbron As Worksheet
Dim shtdoel As Worksheet

Dim pvt As PivotTable
Dim pi As PivotItem

Set wbbron = ActiveWorkbook
Set shtbron = wbbron.Sheets("Blad9")
Set pvt = shtbron.PivotTables("Draaitabel17")

pvt.ShowPages Pagefield:="Monstertype"

Set wbdoel = Workbooks.Add

For Each pi In pvt.PageFields("Monstertype").PivotItems
    wbbron.Sheets(pi.Value).Move after:=wbdoel.Sheets(wbdoel.Sheets.Count) 
Next pi

Application.DisplayAlerts = False
wbdoel.Sheets(1).Delete
Application.DisplayAlerts = True

VulOfferte wbdoel

End Sub

The error occurs on

wbbron.Sheets(pi.Value).Move after:=wbdoel.Sheets(wbdoel.Sheets.Count)

the cry for help: It drives me crazy, please help.

Answer 1

The code below will loop through PivotItems in PivotField " Monstertype ", and will copy a Worksheet to the added Workbook for each Item with its' CurrentPage.

Sub exportPivot()

Dim wbbron          As Workbook
Dim wbdoel          As Workbook

Dim shtbron         As Worksheet
Dim shtdoel         As Worksheet
Dim SrcData         As Range

Dim pvt             As PivotTable
Dim PvtCache        As PivotCache
Dim PvtFld          As PivotField
Dim pi              As PivotItem

Application.ScreenUpdating = False

Set wbbron = ActiveWorkbook
Set shtbron = wbbron.Sheets("Blad9")

' added a Range to dynamic read new rows that were added to the source data of the Pivot Table
' modify "Sheet1" to your Sheet's name (where the Pivot Table data is located)
Set SrcData = Sheets("Sheet1").Range("A1:C" & Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row)

' set Pivot Cache to updated Pivot Table Source Data
Set PvtCache = ActiveWorkbook.PivotCaches.Add(xlDatabase, SrcData)

Set pvt = shtbron.PivotTables("Draaitabel17")
pvt.ChangePivotCache PvtCache ' set updated Cache to Pivot Table
pvt.RefreshTable

Set PvtFld = pvt.PivotFields("Monstertype")

Set wbdoel = Workbooks.Add

' loop through all Pivot Items in Pivot Field "Monstertype" , and copy a new Sheet to added workbook for every item
For Each pi In PvtFld.PivotItems
    PvtFld.CurrentPage = pi.Name

    shtbron.Copy after:=wbdoel.Sheets(wbdoel.Sheets.Count)
    With ActiveSheet
        .Name = pi.Name
        pi.Visible = True
        'PvtFld.CurrentPage = pi.Name
    End With
   ' wbbron.Sheets(pi.Name).Copy after:=wbdoel.Sheets(wbdoel.Sheets.Count)
Next pi

Application.DisplayAlerts = False
wbdoel.Sheets(1).Delete

' you can remove also sheets(2) and (3) if you want to clean-up
'wbdoel.Sheets(2).Delete
'wbdoel.Sheets(3).Delete

Application.DisplayAlerts = True

' don't know this command (NOT IN ENGLISH)
'VulOfferte wbdoel

End Sub

Answer 2

This looks like your pivot table retains items deleted from the data source section. This is not a problem of your VBA code, which looks fine to me. You can change this by right clicking any cell of your pivot table, select "Pivot Table Options". Then click on the "data" tab and change "Retain items deleted from the data source section" to "None".