How to List details of Calculated Items and the Groups used in a Pivot Table using VBA

How to List details of Calculated Items and the Groups used in a Pivot Table using VBA

Dear Forum,

I found a code on the Internet which gives the information of the various fields in a Pivot Table as well as the Calculated Field in a Tabular Form, I tried researching for the information on Groups in a Pivot Table and Calculated Items but didn't find any code.Can some please help me with the same. I want to create a Table of Information of the existing Pivot Tables in Sheet with all the details including the Groups in a Pivot Table as well as the Calculated Field.

In Groups , I have come across different Groups which we do normally , example certain Country Names i.e Text Values can be categorized as Continents , likewise certain Plain Numbers can be divided into groups using a Fixed Difference and the last one I know is that of Dates which can be grouped in Years Months and Quarters. SO I need to capture the information in a pivot table of any of these Groups which are used in the Pivot Table.

Also, if there is a Calculated Item, capture the information of the Pivot Table Calculated Item along with the Formula and the Position and the Items used.


I am attaching a Sample Data where someone can help me with the code

I have 2 Groups one Group is Based on the Sales Column and the other is Dates.

In the Sheet Data+Pivot I have a Pivot Table which has a Calculated item with the Name - 2Mon

Sub LocList_ALL_PTs_PFs()
'contextures.com
'lists all pivot tables in
' active workbook
'use the Notes column to
' add comments about fields
Dim lRow As Long
Dim ws As Worksheet
Dim wsList As Worksheet
Dim pt As PivotTable
Dim pf As PivotField
Dim df As PivotField
Dim pi As PivotItem
Dim lLoc As Long
Dim lPos As Long
Dim pfCount As Long
Dim myList As ListObject
Dim bOLAP As Boolean
Application.DisplayAlerts = False

On Error GoTo errHandler

Set wsList = Sheets.Add
lRow = 2

With wsList
  .Cells(1, 1).Value = "Sheet"
  .Cells(1, 2).Value = "PT Name"
  .Cells(1, 3).Value = "PT Address"
  .Cells(1, 4).Value = "Caption"
  .Cells(1, 5).Value = "Heading"
  .Cells(1, 6).Value = "Source Name"
  .Cells(1, 7).Value = "Location"
  .Cells(1, 8).Value = "Position"
  .Cells(1, 9).Value = "Sample Item"
  .Cells(1, 10).Value = "Formula"
  .Cells(1, 11).Value = "OLAP"
  .Rows(1).Font.Bold = True
  
  For Each ws In ActiveWorkbook.Worksheets
    For Each pt In ws.PivotTables
      bOLAP = pt.PivotCache.OLAP
      
      For pfCount = 1 To pt.RowFields.Count
        Set pf = pt.RowFields(pfCount)
        lLoc = pf.Orientation
        If pf.Caption <> "Values" Then
        .Cells(lRow, 1).Value = ws.Name
        .Cells(lRow, 2).Value = pt.Name
        .Cells(lRow, 3).Value = pt.TableRange2.Address
        .Cells(lRow, 4).Value = pf.Caption
        .Cells(lRow, 5).Value = pf.LabelRange.Address
        .Cells(lRow, 6).Value = pf.SourceName
        .Cells(lRow, 7).Value = lLoc & " - Row"
        .Cells(lRow, 8).Value = pfCount
          On Error Resume Next
          If pf.PivotItems.Count > 0 _
            And bOLAP = False Then
            .Cells(lRow, 9).Value _
                = pf.PivotItems(1).Value
          End If
          On Error GoTo errHandler
        .Cells(lRow, 11).Value = bOLAP
          lRow = lRow + 1
          lLoc = 0
        End If
      Next pfCount
      
      For pfCount = 1 To pt.ColumnFields.Count
        Set pf = pt.ColumnFields(pfCount)
        lLoc = pf.Orientation
        If pf.Caption <> "Values" Then
        .Cells(lRow, 1).Value = ws.Name
        .Cells(lRow, 2).Value = pt.Name
        .Cells(lRow, 3).Value = pt.TableRange2.Address
        .Cells(lRow, 4).Value = pf.Caption
        .Cells(lRow, 5).Value = pf.LabelRange.Address
        .Cells(lRow, 6).Value = pf.SourceName
        .Cells(lRow, 7).Value = lLoc & " - Column"
        .Cells(lRow, 8).Value = pfCount
          On Error Resume Next
          If pf.PivotItems.Count > 0 _
            And bOLAP = False Then
            .Cells(lRow, 9).Value _
                = pf.PivotItems(1).Value
          End If
          On Error GoTo errHandler
        .Cells(lRow, 11).Value = bOLAP
          lRow = lRow + 1
          lLoc = 0
        End If
      Next pfCount
      
      For pfCount = 1 To pt.PageFields.Count
        Set pf = pt.PageFields(pfCount)
        lLoc = pf.Orientation
        .Cells(lRow, 1).Value = ws.Name
        .Cells(lRow, 2).Value = pt.Name
        .Cells(lRow, 3).Value = pt.TableRange2.Address
        .Cells(lRow, 4).Value = pf.Caption
        .Cells(lRow, 5).Value = pf.LabelRange.Address
        .Cells(lRow, 6).Value = pf.SourceName
        .Cells(lRow, 7).Value = lLoc & " - Filter"
        .Cells(lRow, 8).Value = pfCount
        On Error Resume Next
          If pf.PivotItems.Count > 0 _
            And bOLAP = False Then
          .Cells(lRow, 9).Value _
              = pf.PivotItems(1).Value
        End If
        On Error GoTo errHandler
        .Cells(lRow, 11).Value = bOLAP
        lRow = lRow + 1
        lLoc = 0
      Next pfCount
      
      For pfCount = 1 To pt.DataFields.Count
        Set pf = pt.DataFields(pfCount)
        lLoc = pf.Orientation
        
        Set df = pt.PivotFields(pf.SourceName)
        .Cells(lRow, 1).Value = ws.Name
        .Cells(lRow, 2).Value = pt.Name
        .Cells(lRow, 3).Value = pt.TableRange2.Address
        .Cells(lRow, 4).Value = df.Caption
        .Cells(lRow, 5).Value = _
              pf.LabelRange.Cells(1).Address
       .Cells(lRow, 6).Value = df.SourceName
        .Cells(lRow, 7).Value = lLoc & " - Data"

        .Cells(lRow, 8).Value = pfCount
        'sample data not shown for value fields
        On Error Resume Next
          'print formula for calculated fields
          '.Cells(lRow, 6).Value = " " & pf.Formula
            If df.IsCalculated = True Then
              .Cells(lRow, 10).Value = _
                  Right(df.Formula, Len(df.Formula) - 1)
            End If
        On Error GoTo errHandler
         .Cells(lRow, 11).Value = bOLAP
       lRow = lRow + 1
        lLoc = 0
        Set df = Nothing
      Next pfCount
            
    Next pt
  Next ws
  .Columns("A:K").EntireColumn.AutoFit
  Set myList = .ListObjects.Add(xlSrcRange, _
      Range("A1").CurrentRegion)

End With
MsgBox "Done"

exitHandler:
    Application.DisplayAlerts = True
    Exit Sub
errHandler:
    MsgBox "Could not create list"
    Resume exitHandler

End Sub