Thread: Expand & Collapse Pivot Tables in multiple worksheets

Hi Kaseyleigh,

What do you mean by expand or collapse the column.. ?
Is it the double click on the right border to auto - adjust or what?


Regards,
DILIPandey

<click on below 'star' if this helps>

You want the showdetail property of the pivot field - for example

Dim ws as worksheet
dim pt as pivottable
for each ws in worksheets
for each pt in ws.pivottables
' toggle the third row field to expand
pt.rowfields("field name").showdetail = True
next pt
next ws

Unfortunately, the events are not that specific - all you will get is notification that the pivot table has changed, not what or why. You would therefore have to iterate through all the PTs and all the fields and reset the detail level, which is not terribly efficient. I also seem to recall having issues with reading the current ShowDetail value but that might be my memory playing tricks, as I haven't tried it for a while.

Let's try it!

This goes in the ThisWorkbook module of your workbook:

Private Sub Workbook_SheetPivotTableUpdate(ByVal Sh As Object, ByVal Target As PivotTable)
    Dim ptItem As PivotItem
    Dim ptField As PivotField
    Dim pt As PivotTable
    Dim ws As Worksheet
    Dim strField As String
    
    On Error Resume Next
    Set ptItem = ActiveCell.PivotItem
    On Error GoTo Oops
    
    If Not ptItem Is Nothing Then
        Set ptField = ptItem.Parent
        With ptField
            If .Orientation = xlColumnField Or .Orientation = xlRowField Then
                With Application
                    .ScreenUpdating = False
                    .EnableEvents = False
                End With
                strField = .Name
                On Error Resume Next
                For Each ws In ActiveWorkbook.Worksheets
                    For Each pt In ws.PivotTables
                        If Not pt.TableRange1.Address(external:=True) = _
                                Target.TableRange1.Address(external:=True) Then
                            pt.PivotFields(strField).PivotItems(ptItem.Caption).ShowDetail = ptItem.ShowDetail
                        End If
                    Next pt
                Next ws
                On Error GoTo Oops
            End If
        End With
    End If
    
clean_up:
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Exit Sub
    
Oops:
    MsgBox Err.Description
    Resume clean_up

End Sub

Here is a commented version - hopefully it is clear

Private Sub Workbook_SheetPivotTableUpdate(ByVal Sh As Object, ByVal Target As PivotTable)
    Dim ptItem As PivotItem
    Dim ptField As PivotField
    Dim pt As PivotTable
    Dim ws As Worksheet
    Dim strField As String
    
    On Error Resume Next
    ' checks the active cell is in a pivot table
    Set ptItem = ActiveCell.PivotItem
    On Error GoTo Oops
    
    If Not ptItem Is Nothing Then
        ' get the pivot field for the active cell
        Set ptField = ptItem.Parent
        With ptField
            ' check if it's a row or colulmn field
            ' if it isn't, it can't be expanded so no point doing anything
            If .Orientation = xlColumnField Or .Orientation = xlRowField Then
                ' stop screen updates to speed things up
                '
                ' and turn off events so that this code doesn't get triggered
                ' again as we alter each pivot table
                With Application
                    .ScreenUpdating = False
                    .EnableEvents = False
                End With
                ' store name of the pivot field
                strField = .Name
                 ' lazy error handling - just ignores any errors
                ' such as the field not being opresent in one of the tables
               On Error Resume Next
               ' loop through all worksheets and pivot tables
                For Each ws In ActiveWorkbook.Worksheets
                    For Each pt In ws.PivotTables
                        ' check the pivot table in question is not
                        ' the one the user just altered - no need to process that one!
                        If Not pt.TableRange1.Address(external:=True) = _
                                Target.TableRange1.Address(external:=True) Then
                                ' expand or contract the item as applicable
                            pt.PivotFields(strField).PivotItems(ptItem.Caption).ShowDetail = ptItem.ShowDetail
                        End If
                    Next pt
                Next ws
                ' reset error handler
                On Error GoTo Oops
            End If
        End With
    End If
    
clean_up:
    ' this makes sure we cannot exit without turning events back on
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Exit Sub
    
Oops:
    ' this is the error handler
    MsgBox Err.Description
    Resume clean_up

End Sub

My pleasure.

Any chance you can post the workbook?

There aren't many lines there that aren't in an On Error Resume Next block so I'm struggling to see where that error might occur, but worst case you could try removing the two

on error goto Oops

lines