Public Const sRngName = "PT_Notes"
Public Function Check_Setup(ws As Worksheet) As Boolean
Dim rNotes As Range, i As Long, bCompact As Boolean
Dim PT As PivotTable, ptField As PivotField
Dim tblNotes As ListObject
Dim wsSave As Worksheet
'---Check if not exactly one PT on Worksheet- exit
If ws.PivotTables.Count <> 1 Then GoTo StopNotes
Set PT = ws.PivotTables(1)
'---Check if not at least one RowField and one DataField- exit
If PT.DataFields.Count = 0 Or PT.RowFields.Count = 0 Then GoTo StopNotes
'---Check if Named Range "PT_Notes" doesn't exist- define it
If Not NameExists(sRngName, ws.Name) Then
With PT.TableRange1
Set rNotes = Intersect(PT.DataBodyRange.EntireRow, _
.Resize(, 2).Offset(0, .Columns.Count))
End With
Set rNotes = rNotes.Resize(rNotes.Rows.Count _
+ PT.ColumnGrand)
ws.Names.Add Name:=sRngName, RefersTo:=rNotes
Call Format_NoteRange(rNotes)
End If
'---Check if "|Notes" Worksheet doesn't exist- add it
If Not SheetExists(ws.Name & "|Notes") Then
Set wsSave = ActiveSheet
Sheets.Add
ActiveSheet.Name = ws.Name & "|Notes"
wsSave.Activate
End If
'---Check if Notes DataTable doesn't exist- add it
With Sheets(ws.Name & "|Notes")
On Error Resume Next
Set tblNotes = .ListObjects(1)
If tblNotes Is Nothing Then
.Cells(1) = "KeyPhrase"
.Cells(1, 2) = "Note1"
.Cells(1, 3) = "Note2"
Set tblNotes = .ListObjects.Add(xlSrcRange, _
.Range("A1:C2"), , xlYes)
End If
End With
'---Check if any PT fields are not Table Headers - add
With tblNotes
For Each ptField In PT.RowFields
If IsError(Application.Match(ptField.Name, .HeaderRowRange, 0)) Then
.ListColumns.Add Position:=2
.HeaderRowRange(1, 2) = ptField.Name
End If
Next ptField
End With
Check_Setup = True
Exit Function
StopNotes:
If NameExists(sRngName, ws.Name) Then
Application.EnableEvents = False
Call Clear_Notes_Range(ws)
ws.Names(sRngName).Delete
Application.EnableEvents = True
Check_Setup = False
Exit Function
End If
End Function
Private Function Format_NoteRange(rNotes As Range)
'---Format body
With rNotes
.Interior.Color = 16316664
.Font.Italic = True
.HorizontalAlignment = xlLeft
.IndentLevel = 1
.Borders(xlInsideHorizontal).LineStyle = xlDot
.Borders(xlBottom).LineStyle = xlDot
End With
'---Format optional header
With rNotes.Resize(1).Offset(-1)
.Cells(1).Value = "Note1"
.Cells(2).Value = "Note2"
.Interior.Color = 16316664
.Font.Italic = True
.Font.Bold = True
.HorizontalAlignment = xlCenter
.Borders(xlBottom).LineStyle = xlContinuous
End With
End Function
Private Function Clear_Notes_Range(ws As Worksheet)
'---Clear existing notes range
On Error Resume Next
Dim c As Range
With ws.Range(sRngName)
With .Offset(-1).Resize(.Rows.Count + 1)
If Intersect(ws.PivotTables(1).TableRange2, _
.Cells) Is Nothing Then
.ClearContents
.ClearFormats
Else 'PT overlaps notes
For Each c In .Cells
c.ClearContents
c.ClearFormats
Next c
On Error GoTo 0
End If
End With
End With
End Function
Public Function Refresh_Notes(PT As PivotTable)
Dim sField As String, sKey As String, sFormula As String
Dim ptField As PivotField
Dim tblNotes As ListObject
Dim rNotes As Range, c As Range
Dim rLabels As Range, rLabelsAll As Range
Dim vFields As Variant, vReturn As Variant
Dim lPosition As Long, lOffset As Long
Dim i As Long, lIdx As Long
Dim lRow As Long, lCol As Long
'---Clear existing notes range
Call Clear_Notes_Range(ws:=PT.Parent)
'---Redefine and format notes range
With PT.TableRange1
Set rNotes = Intersect(PT.DataBodyRange.EntireRow, _
.Resize(, 2).Offset(0, .Columns.Count))
End With
Set rNotes = rNotes.Resize(rNotes.Rows.Count + PT.ColumnGrand)
PT.Parent.Names(sRngName).RefersTo = rNotes
Call Format_NoteRange(rNotes)
'---Make array of rowfields by position to trace each row in hierarchy
With PT.RowFields
ReDim vFields(1 To .Count)
For lIdx = 1 To .Count
vFields(PT.RowFields(lIdx).Position) = PT.RowFields(lIdx).Name
Next lIdx
End With
'---Build formula to use as Match KeyPhrase
Set tblNotes = Sheets(PT.Parent.Name & "|Notes").ListObjects(1)
With tblNotes
On Error Resume Next
sFormula = "="
For lIdx = LBound(vFields) To UBound(vFields)
lCol = Application.Match(vFields(lIdx), .HeaderRowRange, 0)
sFormula = sFormula & "RC" & lCol & "&""|""&"
Next lIdx
sFormula = Left(sFormula, Len(sFormula) - 1)
Intersect(.DataBodyRange, .ListColumns(1).Range).FormulaR1C1 = sFormula
End With
'---Match KeyPhrases for each visible row of PT
Application.EnableEvents = False
With PT.TableRange1
lOffset = .Column + .Columns.Count - PT.DataBodyRange.Column + 1
End With
With PT.DataBodyRange.Resize(, 1)
For lRow = 1 To .Rows.Count + PT.ColumnGrand
sKey = GetKey(rPC:=.Cells(lRow), vFields:=vFields)
vReturn = Evaluate("=MATCH(""" & _
sKey & """," & tblNotes.Name & "[KeyPhrase],0)")
If (Not IsError(vReturn)) Then
.Cells(lRow, lOffset) = Evaluate("=INDEX(" & tblNotes.Name & "[Note1]," & vReturn & ")")
.Cells(lRow, lOffset + 1) = Evaluate("=INDEX(" & tblNotes.Name & "[Note2]," & vReturn & ")")
End If
Next lRow
End With
Application.EnableEvents = True
End Function
Private Function GetKey(rPC As Range, vFields As Variant) As String
'---for use with Excel 2011 for Mac
Dim sFieldCurr As String, sFieldPrev As String, sNew As String, sField As String
Dim rLabels As Range
Dim lIdx As Long, i As Long, lPosition As Long, lCol As Long
With rPC.PivotTable.RowRange '--Compact layout
If .PivotTable.RowFields(1).LayoutCompactRow Then
lIdx = UBound(vFields) + 1
Set rLabels = .Offset(1).Resize(rPC.Row - .Row)
For i = rLabels.Rows.Count To 1 Step -1
sField = rLabels(i).PivotField.Name
lPosition = Application.Match(sField, vFields, 0)
Do While lIdx > lPosition + 1
GetKey = "|" & GetKey
lIdx = lIdx - 1
Loop
If lPosition < lIdx Then
GetKey = rLabels(i).PivotItem.Name & "|" & GetKey
lIdx = lPosition
If lIdx = 1 Then Exit For
End If
Next i
Else '--Tabular or Outline layout
For lCol = 1 To .Columns.Count
With .Cells(rPC.Row - .Row + 1, lCol)
sFieldCurr = .PivotField.Name
sNew = IIf(sFieldCurr = sFieldPrev, "", .PivotItem.Name)
GetKey = GetKey & sNew & "|"
sFieldPrev = sFieldCurr
End With
Next lCol
End If
End With
End Function
Public Function Update_Note_Database(PT As PivotTable, rNote As Range)
'---for use with Excel 2011 for Mac
Dim rLabels As Range
Dim sField As String, sItem As String
Dim vFields As Variant, tblNotes As ListObject
Dim lPosition As Long, lIdx As Long, lCol As Long
Dim iArray As Variant, i As Integer
'---Make new record of note at top of database table
Set tblNotes = Sheets(PT.Parent.Name & "|Notes").ListObjects(1)
tblNotes.ListRows.Add (1)
tblNotes.ListColumns("Note1").Range(2) = rNote(1).Value
tblNotes.ListColumns("Note2").Range(2) = rNote(1, 2).Value
If PT.RowFields(1).LayoutCompactRow Then '--Compact layout
'---Make array of rowfields by position to trace each row in hierarchy
With PT.RowFields
ReDim vFields(1 To .Count)
For lIdx = 1 To .Count
vFields(PT.RowFields(lIdx).Position) = PT.RowFields(lIdx).Name
Next lIdx
End With
'---Make new record of note at top of database table
lIdx = lIdx + 1
With PT.RowRange
Set rLabels = .Offset(1).Resize(rNote.Row - .Row)
For i = rLabels.Rows.Count To 1 Step -1
sField = rLabels(i).PivotField.Name
lPosition = Application.Match(sField, vFields, 0)
If lPosition < lIdx Then
sItem = rLabels(i).PivotItem.Name
tblNotes.ListColumns(sField).Range(2) = sItem
lIdx = lPosition
If lIdx = 1 Then Exit For
End If
Next i
End With
Else '--Tabular or Outline layout
Set rLabels = Intersect(rNote.EntireRow, PT.RowRange)
For lCol = rLabels.Columns.Count To 1 Step -1
With rLabels(1, lCol)
tblNotes.ListColumns(.PivotField.Name).Range(2) = .PivotItem.Name
End With
Next lCol
End If
'---Remove any previous notes with matching rowfield values
With tblNotes.Range
ReDim iArray(0 To .Columns.Count - 4)
For i = 0 To UBound(iArray)
iArray(i) = i + 2
Next i
.RemoveDuplicates Columns:=(iArray), Header:=xlYes
If rNote(1).Value = "" And rNote(1, 2).Value = "" Then _
tblNotes.ListRows(1).Delete
End With
End Function
Private Function NameExists(sRngName As String, _
sSheetName As String) As Boolean
Dim rTest As Range
On Error Resume Next
Set rTest = Sheets(sSheetName).Range(sRngName)
NameExists = Not rTest Is Nothing
End Function
Private Function SheetExists(sSheetName As String) As Boolean
Dim sTest As String
On Error Resume Next
sTest = Worksheets(sSheetName).Name
SheetExists = LCase(sTest) = LCase(sSheetName)
End Function
Public Function isPivotCell(rCell As Range) As Boolean
'---for use with Excel 2011 for Mac
On Error Resume Next
isPivotCell = Not (IsError(rCell.PivotTable))
End Function
