Option Explicit
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
Dim i As Long
Dim sNew As String
With rPC.PivotCell.RowItems
For i = LBound(vFields) To UBound(vFields)
If i > .Count Then sNew = "" Else sNew = .Item(i).Caption
GetKey = GetKey & sNew & "|"
Next i
End With
End Function
Public Function Update_Note_Database(PT As PivotTable, rNote As Range)
Dim tblNotes As ListObject
Dim rPC As Range
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
Set rPC = Intersect(PT.DataBodyRange.Resize(, 1), rNote.EntireRow)
With rPC.PivotCell.RowItems
For i = 1 To .Count
With .Item(i)
tblNotes.ListColumns(.Parent.Name).Range(2) = .Caption
End With
Next i
End With
'---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
On Error Resume Next
isPivotCell = Not (IsError(rCell.PivotCell))
End Function
