Mike,
Here's a macro that documents a pivot table. Maybe some of the code can help.
--
HTH,
Gary Brown
Option Explicit
'
'/========================================================/
Sub Pivot_Properties()
'Creates a worksheet within the current workbook
' listing pivot table information
'Creates a comment on each pivot table containing an
' abbreviated version of that information
Dim aryHiddensheets()
Dim blnColFields As Boolean, blnShowValues As Boolean
Dim blnMakeComment As Boolean
Dim D As Double, c As Double
Dim i As Long, z As Long, iPtCount As Long
Dim x As Long, y As Long, w As Long
Dim iFieldsCount As Long
Dim iRow As Long, iColumn As Long
Dim iWorksheets As Long
Dim objCalcItem As Object
Dim objCubeFld As Object
Dim objPvtField As Object
Dim objOutputArea As Object
Dim objSheet As Object
Dim strAnswer As String, strComment As String
Dim strResultsTableName As String
' Dim varAnswer As Variant
Dim varPvtField As Variant, varPivotItem As Variant
On Error Resume Next
'/- - - - Variables - - - - - - - -
strResultsTableName = "PivotTableProperties"
strAnswer = ""
strComment = ""
iRow = 1
iColumn = -2
iPtCount = 0
blnColFields = True
blnShowValues = True
blnMakeComment = False
'/- - - - End Variables - - - - - -
blnShowValues = False
' varAnswer = _
' MsgBox("Show Selected Values for each field?" & _
' vbCr & vbCr & _
' "Select 'No' to only show Heading names", _
' vbInformation + vbYesNoCancel + vbDefaultButton2, _
' "Show Values for each field...")
'
' If varAnswer = vbNo Then
' blnShowValues = False
' End If
'
' If varAnswer = vbCancel Then
' MsgBox "This process has been canceled.", _
' vbInformation + vbOKOnly, "Warning..."
' Exit Sub
' End If
'check for an active workbook
'no workbooks open, so create one
If ActiveWorkbook Is Nothing Then
Workbooks.Add
End If
'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count
'redim array
ReDim aryHiddensheets(1 To iWorksheets)
x = 0
y = 0
For Each objSheet In ActiveWorkbook.Sheets
y = y + 1
If objSheet.Visible <> True Then
x = x + 1
aryHiddensheets(x) = objSheet.name
objSheet.Visible = True
End If
Next objSheet
'Check for duplicate Worksheet name
i = ActiveWorkbook.Sheets.Count
For x = 1 To i
If UCase(Worksheets(x).name) = _
UCase(strResultsTableName) Then
Worksheets(x).Activate
If Err.Number = 9 Then
Exit For
End If
'turn warning messages off
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
'turn warning messages on
Application.DisplayAlerts = True
Exit For
End If
Next
'Add new worksheet at end of workbook
' where results will be located
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
'Name the new worksheet and set up Titles
ActiveWorkbook.ActiveSheet.name = strResultsTableName
ActiveWorkbook.ActiveSheet.Range("A1").value = _
"Pivot Table Information"
ActiveWorkbook.ActiveSheet.Range("A1").Font.Bold
ActiveWorkbook.ActiveSheet.Range("A1").Font.Size = 16
ActiveWorkbook.ActiveSheet.Range("A1").Font.Underline = _
xlUnderlineStyleSingle
iWorksheets = ActiveWorkbook.Sheets.Count
Set objOutputArea = _
ActiveWorkbook.Sheets(strResultsTableName).Range("A1")
iRow = iRow + 1
'Go through one Worksheet at a time
For x = 1 To iWorksheets
'Go to Next Worksheet
Worksheets(x).Activate
'Initialize formula and text/value count variables
i = ActiveSheet.PivotTables.Count
iPtCount = iPtCount + i
strComment = ""
If i > 0 And _
UCase(ActiveSheet.name) <> _
UCase(strResultsTableName) Then
blnMakeComment = True
With ActiveSheet
For z = 1 To i
strComment = ""
iColumn = iColumn + 2
ActiveWorkbook.Sheets(strResultsTableName). _
Columns(iColumn + 1) _
.NumberFormat = "@"
With .PivotTables(z)
objOutputArea.Offset(iRow, iColumn) = _
"Pivot Table Name: " & .name
objOutputArea.Offset(iRow, iColumn).Font.Size = 12
objOutputArea.Offset(iRow, _
iColumn).Font.Underline = _
xlUnderlineStyleSingle
objOutputArea.Offset(iRow, iColumn).Font.Bold
iRow = iRow + 1
strComment = strComment & "Pivot Table Name: " & _
.name & Chr(10)
objOutputArea.Hyperlinks.Add _
Anchor:=objOutputArea.Offset(iRow, iColumn), _
Address:=ActiveWorkbook.FullName, _
TextToDisplay:="Location/Name (Workbook): " & _
ActiveWorkbook.FullName
iRow = iRow + 1
objOutputArea.Hyperlinks.Add _
Anchor:=objOutputArea.Offset(iRow, iColumn), _
Address:=ActiveWorkbook.FullName, _
SubAddress:= _
Left(.SourceData, InStr(.SourceData, "!") - 1) & _
"!" & _
Range_RC2A1(Right(.SourceData, Len(.SourceData) - _
InStr(.SourceData, "!"))), _
TextToDisplay:= _
"Data Source of Pivot Table (Worksheet): " & _
Left(.SourceData, _
InStr(.SourceData, "!") - 1) & "!" & _
Range_RC2A1(Right(.SourceData, Len(.SourceData) - _
InStr(.SourceData, "!")))
iRow = iRow + 1
strComment = strComment & _
"Data Source of Pivot Table (Worksheet): " & _
Left(.SourceData, InStr(.SourceData, _
"!") - 1) & "!" & _
Range_RC2A1(Right(.SourceData, Len(.SourceData) - _
InStr(.SourceData, "!"))) & Chr(10)
objOutputArea.Offset(iRow, iColumn) = _
"Data Source - CacheIndex = " & .CacheIndex
iRow = iRow + 1
strComment = strComment & _
"Data Source - CacheIndex = " & _
.CacheIndex & Chr(10)
objOutputArea.Hyperlinks.Add _
Anchor:=objOutputArea.Offset(iRow, iColumn), _
Address:=ActiveWorkbook.FullName, _
SubAddress:=Chr(39) & ActiveSheet.name & _
Chr(39) & "!" & _
.TableRange2.Address, _
TextToDisplay:= _
"Pivot Table Location (Worksheet): " & _
ActiveSheet.name & "!" & _
.TableRange2.Address
iRow = iRow + 1
strComment = strComment & _
"Pivot Table Location (Worksheet): " & _
ActiveSheet.name & "!" & _
.TableRange2.Address & Chr(10) & Chr(10) & Chr(10)
objOutputArea.Offset(iRow, iColumn) = _
"Row Information - Order (#)"
objOutputArea.Offset(iRow, iColumn).Font.Bold
iRow = iRow + 1
objOutputArea.Offset(iRow, iColumn) = _
"Row Heading Field(s): "
iRow = iRow + 1
For Each varPvtField In .RowFields
For w = 1 To .RowFields.Count
If varPvtField.name = .RowFields.item(w) Then
objOutputArea.Offset(iRow, iColumn) = _
" - " & " ( " & _
varPvtField.Position & " ) " & _
varPvtField.name
End If
Next w
c = 0
If varPvtField.name = "Data" Then
If .ColumnFields.Count = 0 Then
blnColFields = False
End If
If .RowFields.Count = 1 Then
objOutputArea.Offset(iRow, iColumn) = _
" - " & varPvtField.name & _
" *** [No Row Fields Selected]"
Else
objOutputArea.Offset(iRow, iColumn) = _
" - " & varPvtField.name
End If
End If
iRow = iRow + 1
For Each varPivotItem In .PivotFields( _
varPvtField.name).PivotItems
If varPivotItem.Visible Then
If blnShowValues = True Then
If c = 0 Then
objOutputArea.Offset(iRow, iColumn) = _
" Selected - " & _
varPivotItem.name
Else
objOutputArea.Offset(iRow, iColumn) = _
" - " & _
varPivotItem.name
End If
iRow = iRow + 1
End If
c = 1
End If
Next varPivotItem
Next varPvtField
If .RowGrand = True Then
objOutputArea.Offset(iRow, iColumn) = _
"Row Grand Total is ON"
Else
objOutputArea.Offset(iRow, iColumn) = _
"Row Grand Total is OFF"
End If
iRow = iRow + 2
objOutputArea.Offset(iRow, iColumn) = _
"Column Information - Order (#)"
iRow = iRow + 1
objOutputArea.Offset(iRow, iColumn) = _
"Column Heading Field(s): "
iRow = iRow + 1
For Each varPvtField In .ColumnFields
c = 0
objOutputArea.Offset(iRow, iColumn) = _
" - " & " ( " & _
varPvtField.Position & " ) " & _
varPvtField.name
iRow = iRow + 1
For Each varPivotItem In _
.PivotFields(varPvtField.name).PivotItems
If varPivotItem.Visible Then
If blnShowValues = True Then
If c = 0 Then
objOutputArea.Offset(iRow, iColumn) = _
" Selected - " & _
varPivotItem.name
Else
objOutputArea.Offset(iRow, iColumn) = _
" - " & _
varPivotItem.name
End If
iRow = iRow + 1
End If
c = 1
End If
Next varPivotItem
Next varPvtField
If blnColFields = False Then
iRow = iRow - 1
objOutputArea.Offset(iRow, iColumn) = _
" - Data" & _
" *** [No Column Fields Selected]"
blnColFields = True
iRow = iRow + 1
End If
If .ColumnGrand = True Then
objOutputArea.Offset(iRow, iColumn) = _
"Column Grand Total is ON"
Else
objOutputArea.Offset(iRow, iColumn) = _
"Column Grand Total is OFF"
End If
iRow = iRow + 2
objOutputArea.Offset(iRow, iColumn) = _
"Data Field(s) - "
iRow = iRow + 1
For Each varPvtField In .DataFields
objOutputArea.Offset(iRow, iColumn) = _
" - " & varPvtField.name
iRow = iRow + 1
Next varPvtField
iRow = iRow + 1
If .PivotFields.Count <> 0 Then
objOutputArea.Offset(iRow, iColumn) = _
"Calculated Items - "
iRow = iRow + 1
iFieldsCount = .PivotFields.Count
For w = 1 To iFieldsCount
For Each objCalcItem In _
.PivotFields(w).CalculatedItems
objOutputArea.Offset(iRow, iColumn) = _
" - Calculation Name: " & _
objCalcItem.name
iRow = iRow + 1
objOutputArea.Offset(iRow, iColumn) = _
" - Field Name: " & _
.PivotFields(w).name
iRow = iRow + 1
objOutputArea.Offset(iRow, iColumn) = _
" - Formula: " & _
objCalcItem.Formula
iRow = iRow + 1
objOutputArea.Offset(iRow, iColumn) = _
" - Solve Order: " & _
.PivotFormulas(objCalcItem.name).Index
iRow = iRow + 1
Next objCalcItem
Next w
End If
iRow = iRow + 1
If .CalculatedFields.Count <> 0 Then
objOutputArea.Offset(iRow, iColumn) = _
"Calculated Fields - "
iRow = iRow + 1
iFieldsCount = .CalculatedFields.Count
For Each objCalcItem In .CalculatedFields
objOutputArea.Offset(iRow, iColumn) = _
" - Calculation Name: " & _
objCalcItem.name
iRow = iRow + 1
objOutputArea.Offset(iRow, iColumn) = _
" - Formula: " & _
objCalcItem.Formula
iRow = iRow + 1
Next objCalcItem
End If
iRow = iRow + 1
If .PageFields.Count <> 0 Then
objOutputArea.Offset(iRow, iColumn) = _
"Page Name(s): "
iRow = iRow + 1
For Each varPvtField In .PageFields
objOutputArea.Offset(iRow, iColumn) = _
" - " & varPvtField.name
iRow = iRow + 1
objOutputArea.Offset(iRow, iColumn) = _
" Show - " & _
.PivotFields(varPvtField.name). _
CurrentPage
iRow = iRow + 1
c = 1
Next varPvtField
iRow = iRow + 1
End If
If .CubeFields.Count <> 0 Then
If Err.Number <> 1004 Then
For Each objCubeFld In .CubeFields
objOutputArea.Offset(iRow, iColumn) = _
"Cube Field Names - " & objCubeFld.name
iRow = iRow + 1
Next objCubeFld
End If
End If
If .DisplayNullString = True And _
Len(.NullString) <> 0 Then
objOutputArea.Offset(iRow, iColumn) = _
"Custom Null String: " & .NullString
iRow = iRow + 1
End If
If .DisplayErrorString = True Then
objOutputArea.Offset(iRow, iColumn) = _
"Custom Error String: " & .ErrorString
iRow = iRow + 1
End If
If .EnableDrilldown = True Then
objOutputArea.Offset(iRow, iColumn) = _
"Drilldown is enabled"
iRow = iRow + 1
End If
If .ShowDetail = True Then
objOutputArea.Offset(iRow, iColumn) = _
"Inner Detail: " & .InnerDetail
iRow = iRow + 1
End If
If .ManualUpdate = True Then
objOutputArea.Offset(iRow, iColumn) = _
"Manual Update is ON"
Else
objOutputArea.Offset(iRow, iColumn) = _
"Automatic Update is ON"
End If
iRow = iRow + 1
If .MergeLabels = True Then
objOutputArea.Offset(iRow, iColumn) = _
"Merge Labels is ON"
iRow = iRow + 1
End If
objOutputArea.Offset(iRow, iColumn) = _
"Pivot Table Refresh Rate: " & _
.PivotCache.RefreshPeriod
iRow = iRow + 1
objOutputArea.Offset(iRow, iColumn) = _
"Last Refresh Date: " & .RefreshDate
iRow = iRow + 1
objOutputArea.Offset(iRow, iColumn) = _
"Data last refreshed by: " & .RefreshName
iRow = iRow + 1
If .SaveData = True Then
objOutputArea.Offset(iRow, iColumn) = _
"Data for Pivot Table report is " & _
"saved with the workbook"
Else
objOutputArea.Offset(iRow, iColumn) = _
"Data for Pivot Table report is " & _
"NOT saved with the workbook"
End If
iRow = iRow + 2
objOutputArea.Offset(iRow, _
iColumn).Interior.ColorIndex = 42
End With
iRow = 2
If blnMakeComment = True Then
Call MakeComment(strComment, _
.PivotTables(z).TableRange2.Address)
End If
Next z
End With
End If
blnMakeComment = False
Next x
Set objOutputArea = Nothing
Cells.Select
Selection.ColumnWidth = 2
Cells.EntireColumn.AutoFit
ActiveWindow.Zoom = 75
For D = 1 To _
ActiveSheet.Cells.SpecialCells(xlLastCell).Column
If Columns(D).ColumnWidth > 125 Then
With Columns(D)
.ColumnWidth = 125
.WrapText = True
End With
End If
Next D
Range("A1").Select
If iPtCount = 0 Then
'turn warning messages off
Application.DisplayAlerts = False
ActiveSheet.Delete
'turn warning messages on
Application.DisplayAlerts = True
MsgBox _
"There are no Pivot Tables in the active workbook..." & _
vbCr & _
vbCr & Chr(34) & ActiveWorkbook.FullName & Chr(34), _
vbCritical + vbOKOnly, "Warning..."
Else
'format for printing
With ActiveSheet.PageSetup
.PrintGridlines = True
.PrintTitleRows = "$1:$6"
.Orientation = xlPortrait
.Order = xlDownThenOver
.Zoom = False
.FitToPagesWide = iPtCount
.FitToPagesTall = False
.CenterHorizontally = True
.CenterVertically = False
End With
End If
're-hide previously hidden sheets
On Error Resume Next
y = UBound(aryHiddensheets)
For Each objSheet In ActiveWorkbook.Sheets
For x = 1 To y
If objSheet.name = aryHiddensheets(x) Then
objSheet.Visible = False
End If
Next x
Next objSheet
If iPtCount <> 0 Then
Application.Dialogs(xlDialogWorkbookName).Show
End If
End Sub
'/=====================================/
Private Sub MakeComment(strDetailInfo As String, _
strAddress As String)
'create comment with pivot information in it [strDetailInfo]
'strAddress is full address of Pivot Table being processed
Dim strFirstCellInAddress As String
'get first cell in range
strFirstCellInAddress = GetFirstCell(strAddress)
'if a comment exists, delete it if created by an earlier run
' of this macro, then create a new one
If CommentExists(strFirstCellInAddress) = False Then
Range(strFirstCellInAddress).AddComment
Else
If UCase(Left( _
Range(strFirstCellInAddress).Comment.Text, 16)) = _
"PIVOT TABLE NAME" Then
Range(strFirstCellInAddress).Comment.Delete
Range(strFirstCellInAddress).AddComment
End If
End If
With Range(strFirstCellInAddress).Comment
.Visible = False
If Len(.Text) > 0 Then
.Text Text:=.Text & Chr(10) & strDetailInfo
Else
.Text Text:=strDetailInfo
End If
.Shape.ScaleHeight 1.75, msoFalse, msoScaleFromTopLeft
.Shape.ScaleWidth 2, msoFalse, msoScaleFromTopLeft
' .Visible = True
End With
End Sub
'/=============================================/
Private Function CommentExists(strRng As String) As Boolean
'test if there is a comment in the current range [strRng]
'return False if no Comment / True if cell has comment
Dim rng As Range
On Error GoTo err_Function
CommentExists = True
Set rng = Range(strRng)
If rng.Comment Is Nothing Then
CommentExists = False
End If
' Set cmtComment = rng.Comment
' If cmtComment Is Nothing Then
' CommentExists = False
' End If
exit_Function:
Set rng = Nothing
Exit Function
err_Function:
CommentExists = False
GoTo exit_Function
End Function
'/=============================================/
Private Function GetFirstCell(strFullRng As String) As String
'get 1st cell in a range / Return offset of 2 columns
'for example: in $A$5:$D$9, $C$5 is returned
Dim rng As Range
Dim strFirstCell As String
On Error GoTo err_Function
strFirstCell = _
Left(strFullRng, _
Application.WorksheetFunction.Find(":", strFullRng) - 1)
Set rng = Range(strFirstCell).Offset(0, 2)
GetFirstCell = rng.Address
exit_Function:
Set rng = Nothing
Exit Function
err_Function:
GetFirstCell = "C1"
GoTo exit_Function
End Function
'/=============================================/