Option Explicit
Public Const sRngName = "PT_Notes"
Public Function Check_Setup(ws As Worksheet) As Boolean
Dim rNotes As Range, i As Long
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 Compact Report layout- exit
For Each ptField In PT.RowFields
If Not ptField.LayoutCompactRow Then GoTo StopNotes
Next ptField
'---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(, 1).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) = "Note"
Set tblNotes = .ListObjects.Add(xlSrcRange, _
.Range("A1:B2"), , 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)(0)
.Value = "Notes"
.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, 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(, 1).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.RowRange
Set rLabelsAll = .Offset(1).Resize(.Rows.Count - 1)
lOffset = PT.TableRange1.Columns.Count + 1
For Each c In rLabelsAll
lIdx = UBound(vFields) + 1
sKey = ""
Set rLabels = .Offset(1).Resize(c.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
sKey = "|" & sKey
lIdx = lIdx - 1
Loop
If lPosition < lIdx Then
sKey = rLabels(i).PivotItem.Name & "|" & sKey
lIdx = lPosition
If lIdx = 1 Then Exit For
End If
Next i
vReturn = Evaluate("=INDEX(" & tblNotes.Name & "[Note],MATCH(""" & _
sKey & """," & tblNotes.Name & "[KeyPhrase],0))")
If (Not IsError(vReturn)) Then c(1, lOffset) = CStr(vReturn)
Next c
End With
Application.EnableEvents = True
End Function
Public Function Update_Note_Database(PT As PivotTable, rNote As Range)
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
Dim iArray As Variant, i As Integer
'---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
Set tblNotes = Sheets(PT.Parent.Name & "|Notes").ListObjects(1)
tblNotes.ListRows.Add (1)
tblNotes.ListColumns("Note").Range(2) = rNote.Value
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
'---Remove any previous notes with matching rowfield values
With tblNotes.Range
ReDim iArray(0 To .Columns.Count - 3)
For i = 0 To UBound(iArray)
iArray(i) = i + 2
Next i
.RemoveDuplicates Columns:=(iArray), Header:=xlYes
If rNote = vbNullString 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
