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 Compact Layout option is same for all fields (True or False)
Select Case PT.RowFields.Count
Case 1: 'do nothing
Case 0: GoTo StopNotes
Case Else
bCompact = PT.RowFields(1).LayoutCompactRow
For i = 2 To PT.RowFields.Count
If PT.RowFields(i).LayoutCompactRow <> bCompact _
Then GoTo StopNotes
Next i
End Select
'---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) = "Ops Notes"
.Cells(1, 3) = "PDR Notes"
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 = False
.HorizontalAlignment = xlLeft
.IndentLevel = 1
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlBottom).LineStyle = xlContinuous
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlLeft).LineStyle = xlContinuous
.EntireColumn.AutoFit
End With
'---Format optional header
With rNotes.Resize(1).Offset(-1)
.Cells(1).Value = "Calculation Details"
.Cells(2).Value = "Back-Up Doc Links"
.Interior.Color = 16316664
.Font.Italic = False
.Font.Bold = True
.HorizontalAlignment = xlCenter
.Borders(xlBottom).LineStyle = xlContinuous
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlTop).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
lOffset = PT.TableRange1.Columns.Count + 1
With PT.RowRange
For lRow = 2 To .Rows.Count
sKey = GetKey(rRowRange:=.Cells, _
lNoteRow:=.Row + lRow - 1, vFields:=vFields)
vReturn = Evaluate("=MATCH(""" & _
sKey & """," & tblNotes.Name & "[KeyPhrase],0)")
If (Not IsError(vReturn)) Then
.Cells(lRow, lOffset) = Evaluate("=INDEX(" & tblNotes.Name & "[Ops Notes]," & vReturn & ")")
.Cells(lRow, lOffset + 1) = Evaluate("=INDEX(" & tblNotes.Name & "[PDR Notes]," & vReturn & ")")
Dim Hyperlink As Hyperlink
If Evaluate("=INDEX(" & tblNotes.Name & "[Ops Notes]," & vReturn & ")").Hyperlinks.Count > 0 Then
Set Hyperlink = Evaluate("=INDEX(" & tblNotes.Name & "[Ops Notes]," & vReturn & ")").Hyperlinks(1)
If (Hyperlink.SubAddress = "") Then
.Cells(lRow, lOffset).Hyperlinks.Add .Cells(lRow, lOffset), Hyperlink.Address
Else
.Cells(lRow, lOffset).Hyperlinks.Add .Cells(lRow, lOffset), Hyperlink.Address, Hyperlink.SubAddress
End If
End If
If Evaluate("=INDEX(" & tblNotes.Name & "[PDR Notes]," & vReturn & ")").Hyperlinks.Count > 0 Then
Set Hyperlink = Evaluate("=INDEX(" & tblNotes.Name & "[PDR Notes]," & vReturn & ")").Hyperlinks(1)
If (Hyperlink.SubAddress = "") Then
.Cells(lRow, lOffset + 1).Hyperlinks.Add .Cells(lRow, lOffset + 1), Hyperlink.Address
Else
.Cells(lRow, lOffset + 1).Hyperlinks.Add .Cells(lRow, lOffset + 1), Hyperlink.Address, Hyperlink.SubAddress
End If
End If
End If
Next lRow
End With
Application.EnableEvents = True
End Function
Private Function GetKey(rRowRange As Range, lNoteRow As Long, _
vFields As Variant) As String
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 rRowRange '--Compact layout
If .PivotTable.RowFields(1).LayoutCompactRow Then
lIdx = UBound(vFields) + 1
Set rLabels = .Offset(1).Resize(lNoteRow - .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(lNoteRow - .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)
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
Dim Hyperlink As Hyperlink
Set tblNotes = Sheets(PT.Parent.Name & "|Notes").ListObjects(1)
tblNotes.ListRows.Add (1)
tblNotes.ListColumns("Ops Notes").Range(2) = rNote(1).Value
tblNotes.ListColumns("PDR Notes").Range(2) = rNote(1, 2).Value
If rNote(1).Hyperlinks.Count > 0 Then
Set Hyperlink = rNote(1).Hyperlinks(1)
Dim range1
Set range1 = tblNotes.ListColumns("Ops Notes").Range(2)
If (Hyperlink.SubAddress = "") Then
tblNotes.ListColumns("Ops Notes").Range(2).Hyperlinks.Add range1, Hyperlink.Address
Else
tblNotes.ListColumns("Ops Notes").Range(2).Hyperlinks.Add range1, Hyperlink.Address, Hyperlink.SubAddress
End If
End If
If rNote(1, 2).Hyperlinks.Count > 0 Then
Set Hyperlink = rNote(1, 2).Hyperlinks(1)
Dim range2
Set range2 = tblNotes.ListColumns("PDR Notes").Range(2)
If (Hyperlink.SubAddress = "") Then
tblNotes.ListColumns("PDR Notes").Range(2).Hyperlinks.Add range2, Hyperlink.Address
Else
tblNotes.ListColumns("PDR Notes").Range(2).Hyperlinks.Add range2, Hyperlink.Address, Hyperlink.SubAddress
End If
End If
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
