Expanding pivot table

When you double click on some of the summarized data on the pivot table it creates a new sheet listing the entire data.

I like this feature, but I do not want lots of extra sheets. Can I get this data to open in a new workbook each time?

Click to expand...

Private Sub Workbook_NewSheet(ByVal Sh As Object)
Call DrillDownDefault
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
CS = ActiveSheet.Name
Application.ScreenUpdating = False
Dim LPTR&
With ActiveSheet.PivotTables(1).DataBodyRange
LPTR = .Rows.Count + .Row - 1
End With
Dim PTT As Integer
On Error Resume Next
PTT = Target.PivotCell.PivotCellType
If Err.Number = 1004 Then
Err.Clear
Cancel = True
End If
Application.ScreenUpdating = True
End Sub

Public CS$

Sub DrillDownDefault()
Dim asn$
asn = ActiveSheet.Name
With Application
.ScreenUpdating = False
Workbooks.Add 1
ThisWorkbook.Worksheets(asn).Range("A1").CurrentRegion.Copy Range("A1")
ThisWorkbook.Activate
.DisplayAlerts = False
Sheets(asn).Delete
.DisplayAlerts = True
Sheets(CS).Select
.ScreenUpdating = True
End With
End Sub

Tom Urtis said:

Yes this is possible.

Find the small Excel icon just to the left of the File menu item on the menu bar. Right click on that icon, left click on View Code, and paste this into the large white area that is the Workbook module:

Code:

Private Sub Workbook_NewSheet(ByVal Sh As Object)
Call DrillDownDefault
End Sub

While you are in the VBE, press Ctrl+R to show the VBAProject window. For your workbook, find the worksheet object name that is the worksheet module for the sheet where your pivot table exists. It will look something like "Sheet1(Sheet1)" depending on what the sheet tab is named which would be inside the parentheses. Right click on that sheet object name, left click on View Code, and paste this into the large white area that is the worksheet module:

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
CS = ActiveSheet.Name
Application.ScreenUpdating = False
Dim LPTR&
With ActiveSheet.PivotTables(1).DataBodyRange
LPTR = .Rows.Count + .Row - 1
End With
Dim PTT As Integer
On Error Resume Next
PTT = Target.PivotCell.PivotCellType
If Err.Number = 1004 Then
Err.Clear
Cancel = True
End If
Application.ScreenUpdating = True
End Sub

Finally, while still in the VBE, from the menu, click Insert > Module and paste this into that new module:

Code:

Public CS$
 
Sub DrillDownDefault()
Dim asn$
asn = ActiveSheet.Name
With Application
.ScreenUpdating = False
Workbooks.Add 1
ThisWorkbook.Worksheets(asn).Range("A1").CurrentRegion.Copy Range("A1")
ThisWorkbook.Activate
.DisplayAlerts = False
Sheets(asn).Delete
.DisplayAlerts = True
Sheets(CS).Select
.ScreenUpdating = True
End With
End Sub

Finally, press Alt+Q to return to the worksheet.

Now when you double click onto the Data area of the pivot table, the drill down info will be in its own workbook without a new sheet created.

The only issue needing to be addressed, which I did not do in code here because you did not specify, is if you want to save and name those individual workbooks. Go ahead and do that yourself in code, or post back if you don't know how.

Click to expand...

Sub Hylkyehdotus()
'
' Hylkyehdotus Macro
'
    Dim rngArea As Range
    With Sheets("TOY Mill Stocks").PivotTables("PivotTable2").TableRange1
        .Cells(.Cells.Count).ShowDetail = True
        For Each rngArea In Range("B:B,E:G,J:J,L:AZ,BB:BG").Areas
            rngArea.Delete
        Next rngArea
    End With
 
End Sub

Tom Urtis said:

This speaks to deleting part ofa pivottable subset, so you should be able to do it if you copy and paste special for values the subset. However, doing what you say you want to do would not give an accurate portrayal of the subset data, so why do you want to do this?

Click to expand...

Magerator said:

That way she will get notified that "new waste proposal has been made".

Click to expand...