Hi @
lofiloop,
Below is some code to try, along with some setup steps.
Paste this code into the ThisWorkbook Module...
Code:
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, _
ByVal Target As Range, Cancel As Boolean)
'---If user double-clicks in PivotTable data, assigns a string reference to
'--- the Pivot Table's SourceData Property to Public string sSourceDataR1C1
On Error GoTo ResetPublicStrings
With Target.PivotCell
If .PivotCellType = xlPivotCellValue And _
.PivotTable.PivotCache.SourceType = xlDatabase Then
sSourceDataR1C1 = .PivotTable.SourceData
sPivotName = .PivotTable.Parent.Name & "!" & .PivotTable.Name
End If
End With
Exit Sub
ResetPublicStrings:
sSourceDataR1C1 = vbNullString
sPivotName = vbNullString
End Sub
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Dim tblNew As ListObject
On Error Resume Next
Set tblNew = Cells(1).ListObject
On Error GoTo 0
If tblNew Is Nothing Then Exit Sub
Call Format_PT_Detail(tblNew)
End Sub
Paste this code into a Standard Code Module...
The names in red need to be modified to match the sheet names, table names, and pivottable names in your workbook.
Code:
Public sSourceDataR1C1 As String
Public sPivotName As String
Public Sub Format_PT_Detail(tblNew As ListObject)
'---Called by Workbook_NewSheet; Passes ShowDetai table object
'---Uses Pivot Table's SourceData Property stored in Public sSourceDataR1C1
'--- to read apply NumberFormats in first row of SourceData to tblNew
Dim cSourceTopLeft As Range
Dim lCol As Long
Dim sSourceDataA1 As String
If sSourceDataR1C1 = vbNullString Then Exit Sub
sSourceDataA1 = Application.ConvertFormula(sSourceDataR1C1, _
xlR1C1, xlA1)
Set cSourceTopLeft = Range(sSourceDataA1).Cells(1)
With tblNew
For lCol = 1 To .Range.Columns.Count
.ListColumns(lCol).Range.NumberFormat = _
cSourceTopLeft(2, lCol).NumberFormat
Next lCol
'Optional to do additional formatting
Call Format_Table(tbl:=tblNew)
tblNew.Unlist 'Optional: Converts Table to Standard Range
End With
'--reset public vars
sSourceDataR1C1 = vbNullString
sPivotName = vbNullString
End Sub
Private Sub Format_Table(tbl As ListObject)
'---Uses the information in rFieldFormats to format the Table
' 4 columns in rFieldFormats define:
' Field | Table Part | Property | New Property Value
' Example: Net Sales | Data | NumberFormat | "$#,##0.00"
Dim rCell As Range, rFieldFormats As Range
Dim sField As String, sFieldRef As String, sTblPart As String
Dim sProperty As String, sNewValue As String
On Error Resume Next
'--edit to map each PivotName to a specific drilldown format range
With Sheets("[COLOR=#FF0000]DrillDownFormats[/COLOR]")
Select Case sPivotName
Case "[COLOR=#FF0000]PivotSheet1!PivotTable3[/COLOR]"
Set rFieldFormats = .ListObjects("[COLOR=#FF0000]FormatTable1[/COLOR]").DataBodyRange
Case "[COLOR=#FF0000]PivotSheet2!PivotTable8[/COLOR]"
Set rFieldFormats = .ListObjects("[COLOR=#FF0000]FormatTable2[/COLOR]").DataBodyRange
Case Else
'--optional: default drill down format of pivots not listed above
Set rFieldFormats = .ListObjects("[COLOR=#FF0000]FormatTable1[/COLOR]").DataBodyRange
End Select
End With
For Each rCell In rFieldFormats.Resize(, 1)
sField = rCell(1, 1)
sTblPart = rCell(1, 2)
sProperty = rCell(1, 3)
sNewValue = rCell(1, 4)
sNewValue = Replace(sNewValue, """", "") 'remove any quotes
Select Case sTblPart
Case "Data"
sFieldRef = tbl.Name & "[" & sField & "]"
Case "Header"
sFieldRef = tbl.Name & "[[#Headers]," & _
"[" & sField & "]]"
Case Else 'Default to Both Data and Header
sFieldRef = tbl.Name & "[[#All]," & _
"[" & sField & "]]"
End Select
With Range(sFieldRef)
Select Case sProperty
Case "WrapText"
.WrapText = sNewValue
Case "AutoFit"
.EntireColumn.AutoFit
Case "ColumnWidth"
.EntireColumn.ColumnWidth = sNewValue
Case "Boss Favorite"
.WrapText = True
With .Font
.Name = "Arial Narrow"
.Bold = True
.Size = 12
End With
Case "Color"
.Interior.Color = sNewValue
Case "Delete"
.EntireColumn.Delete
Case "Font"
.Font = sNewValue
Case "Hidden"
.EntireColumn.Hidden = sNewValue
Case "NumberFormat"
.NumberFormat = sNewValue
Case ""
'---No formatting changes
Case "Property or Method"
'---rFieldFormats Header Row
Case Else
MsgBox sProperty & " is not a defined Property " & _
"or Method in Function Format_Table"
End Select
End With
Next rCell
End Sub
Add a sheet in your workbook and name it "DrillDownFormats". This is the sheet where you will put tables that provide the additional formatting for each specified PivotTable's drill down data. I think it's better to use Excel tables for this instead of standard ranges in case they get moved on the sheet. Name the tables "FormatTable1" and "FormatTable2", or else modify the VBA code in Sub Format_Table to match the names you use.
Here's an example based on the fields in the old thread you linked.
Excel 2016
| A | B | C | D |
|---|
| 1 | FormatTable1 | | | |
| 2 | Data Source Header | Table Part | Property or Method | Value |
| 3 | Letting Date | Both | Hidden | TRUE |
| 4 | Designer | Data | | |
| 5 | Office | | Hidden | TRUE |
| 6 | Contractor | Both | Hidden | TRUE |
| 7 | Project Awarded Amount | Data | NumberFormat | "$#,##0.00" |
| 8 | Project Authorized Amount | | Delete | |
| 9 | Awarded Quantity | Data | NumberFormat | "0.000" |
| 10 | Awarded Quantity | Data | Color | 10092543 |
| 11 | From Quantity | Both | Boss Favorite | |
| 12 | Contract Modification Number | Both | ColumnWidth | 12 |
| 13 | Contract Modification Number | Header | WrapText | TRUE |
| 14 | | | | |
| 15 | FormatTable2 | | | |
| 16 | Data Source Header | Table Part | Property or Method | Value |
| 17 | Project Awarded Amount | Data | ColumnWidth | 20 |
| 18 | Project Authorized Amount | | Delete | |
| 19 | Awarded Quantity | Data | NumberFormat | "0.0" |
<colgroup><col style="width: 25pxpx"><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>
DrillDownFormats
Lastly, modify the VBA code in Sub Format_Table so that your PivotTables are mapped using the pattern "Sheetname!PivotTableName" to match the actual names in your workbook.
