Option Explicit
Public Const sRngName = "PT_Notes"
'Names of the columns separated by the "|" character (without spaces)
'WARNING: Using the same column name for multiple comment columns will have unintended results.
Public Const noteColumnNames = "Comments|SecondComments"
Public Const GapColumns = 1
Public NoteNumber
Public Note() As String
'---Call Note Naming to Set The Column Headers as Defined by the Constant Declared Above
Public Sub noteNames()
Dim vntTemp As Variant
Dim intIndex As Integer
vntTemp = Split(noteColumnNames, "|")
'---Define the number of note columns based on noteColumnNames
NoteNumber = UBound(vntTemp)
'---Separate the noteColumnNames into a public string array available to other subs
ReDim Note(NoteNumber)
For intIndex = 0 To NoteNumber
Note(intIndex) = vntTemp(intIndex)
Next
End Sub
'Public Const Named Range Needs to be Unprotected
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
Dim CommentSheet As Worksheet
'---Call Note Naming to Set The Column Headers as Defined by the Constant Declared Above
Call noteNames
'---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(, NoteNumber + 1).Offset(0, .Columns.Count + GapColumns))
End With
Set rNotes = rNotes.Resize(rNotes.Rows.Count _
+ PT.ColumnGrand)
Ws.Names.Add Name:=sRngName, RefersTo:=rNotes
Ws.Names(sRngName).Visible = False
Call Format_NoteRange(rNotes)
End If
'---CHECK IF NAMED RANGE "PT_Notes" OVERLAPS PIVOT TABLE, IF IT DOES REDEFINE
If OverlappingRanges(PT.TableRange2, Ws.Range(sRngName)) Then
With PT.TableRange1
Set rNotes = Intersect(PT.DataBodyRange.EntireRow, _
.Resize(, 1).Offset(0, .Columns.Count + GapColumns))
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(Left(Ws.Name, 25) & "|Notes") Then
Set wsSave = ActiveSheet
Sheets.Add
ActiveSheet.Name = Left(Ws.Name, 25) & "|Notes"
ActiveSheet.Visible = xlVeryHidden
wsSave.Activate
End If
Set CommentSheet = Sheets(Left(Ws.Name, 25) & "|Notes")
'---Check if Notes DataTable doesn't exist- add it
With CommentSheet
On Error Resume Next
Set tblNotes = .ListObjects(1)
If tblNotes Is Nothing Then
.Cells(1) = "KeyPhrase"
For i = 0 To NoteNumber
.Cells(1, i + 2) = Note(i)
Next i
Set tblNotes = .ListObjects.Add(xlSrcRange, _
.Range("A1:" & Cells(2, NoteNumber + 2).Address(False, False)), , xlYes)
End If
.Visible = xlSheetVeryHidden
End With
'---Check if any PT fields are not Table Headers - add
'---Also check that note column names defined by user exist in worksheet. If not, add them.
With tblNotes
For Each ptField In PT.RowFields
If IsError(Application.Match("Key|" & ptField.SourceName, .HeaderRowRange, 0)) Then
.ListColumns.Add Position:=2
.HeaderRowRange(1, 2) = "Key|" & ptField.SourceName
End If
Next ptField
For i = 0 To NoteNumber
If IsError(Application.Match(Note(i), .HeaderRowRange, 0)) Then
.ListColumns.Add Position:=.ListColumns.Count + 1
.HeaderRowRange(1, .ListColumns.Count) = Note(i)
End If
Next i
End With
'---Setup is now valid
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)
Application.EnableEvents = False
Dim i As Integer
'---Call Note Naming to Set The Column Headers as Defined by the Constant Declared Above
Call noteNames
'---Format body
With rNotes
.Interior.Color = 16316664
.Font.Italic = True
.HorizontalAlignment = xlLeft
.IndentLevel = 1
.Borders(xlInsideHorizontal).LineStyle = xlDot
.Borders(xlInsideVertical).LineStyle = xlDot
.Borders(xlBottom).LineStyle = xlDot
.WrapText = True
.Locked = False
End With
'---Format optional header
With rNotes.Resize(1).Offset(-1)
For i = 0 To NoteNumber
.Cells(1, i + 1).Value = Note(i)
Next i
.Interior.Color = 16316664
.Font.Italic = True
.Font.Bold = True
.HorizontalAlignment = xlCenter
.Borders(xlBottom).LineStyle = xlContinuous
.WrapText = True
.Locked = True
End With
Application.EnableEvents = True
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, lrow As Long, lCol As Long
'---Call Note Naming to Set The Column Headers as Defined by the Constant Declared Above
Call noteNames
'---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(, NoteNumber + 1).Offset(0, .Columns.Count + GapColumns))
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) = "Key|" & PT.RowFields(lIdx).SourceName
Next lIdx
End With
'---Build formula to use as Match KeyPhrase
Set tblNotes = Sheets(Left(PT.Parent.Name, 25) & "|Notes").ListObjects(1)
With tblNotes
On Error Resume Next
sFormula = "="
For i = 2 To .HeaderRowRange.Columns.Count
If Left(.HeaderRowRange.Cells(1, i), 4) <> "Key|" Then Exit For
sFormula = sFormula & "RC" & i & "&""|""&"
Next i
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
If .Cells(lrow, lOffset - 1).Value <> "" Then
sKey = GetKey(rPC:=.Cells(lrow), vFields:=vFields, tblNotes:=tblNotes)
vReturn = Evaluate("=MATCH(""" & _
sKey & """," & tblNotes.Name & "[KeyPhrase],0)")
If (Not IsError(vReturn)) Then
For i = 0 To NoteNumber
.Cells(lrow, lOffset + i + GapColumns) = Evaluate("=INDEX(" & tblNotes.Name & "[" & Note(i) & "]" & "," & vReturn & ")")
Next i
End If
End If
Next lrow
End With
Application.EnableEvents = True
End Function
Private Function GetKey(rPC As Range, vFields As Variant, tblNotes As ListObject) As String
Dim i As Long, vIdx As Long
Dim sNew As String
With tblNotes.HeaderRowRange
GetKey = ""
For i = 2 To .Columns.Count
If Left(.Cells(1, i), 4) <> "Key|" Then Exit For
For vIdx = LBound(vFields) To rPC.PivotCell.RowItems.Count
If .Cells(1, i) = vFields(vIdx) Then
sNew = rPC.PivotCell.RowItems.Item(vIdx).SourceNameStandard 'Changed from Caption to SourceNameStandard 2019-05-11
If IsDate(sNew) Then sNew = CLng(DateValue(sNew)) 'Avoid Date Formatting Errors - pvanerk March 9, 2017
Exit For
Else: End If
Next vIdx
GetKey = GetKey & sNew & "|"
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
Dim empt As Boolean
'---Call Note Naming to Set The Column Headers as Defined by the Constant Declared Above
Call noteNames
empt = True
'---Make new record of note at top of database table
Set tblNotes = Sheets(Left(PT.Parent.Name, 25) & "|Notes").ListObjects(1)
tblNotes.ListRows.Add (1)
For i = 0 To NoteNumber
tblNotes.ListColumns(Note(i)).Range(2) = rNote(1, i + 1).Value
Next i
Set rPC = Intersect(PT.DataBodyRange.Resize(, 1), rNote.EntireRow)
With rPC.PivotCell.RowItems
For i = 1 To .Count
With .Item(i)
tblNotes.ListColumns("Key|" & .Parent.SourceName).Range(2) = .SourceNameStandard 'Changed from Caption to SourceNameStandard 2019-05-11
End With
Next i
End With
tblNotes.Parent.Calculate
'---Remove any previous notes with matching rowfield values
With tblNotes.Range
For i = 2 To .Columns.Count
If Left(.Cells(1, i), 4) <> "Key|" Then Exit For
Next i
ReDim iArray(0 To i - 3)
For i = 0 To UBound(iArray)
iArray(i) = i + 2
Next i
.RemoveDuplicates Columns:=(iArray), Header:=xlYes
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
Function OverlappingRanges(objRange1 As Range, objRange2 As Range) As Boolean
OverlappingRanges = False
If objRange1 Is Nothing Then Exit Function
If objRange2 Is Nothing Then Exit Function
If Not Application.Intersect(objRange1, objRange2) Is Nothing Then
OverlappingRanges = True
End If
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
Sub WorksheetChanges(Rng As Range, Ws As Worksheet)
Dim rNotesChanged As Range
Dim ptrows As Integer
Dim Pvt As PivotTable
'Avoid error if user changes windows during a worksheet edit
If ActiveSheet.Name <> Ws.Name Then Exit Sub
'Avoid error appearing if selection is not a valid range
If TypeName(Selection) <> "Range" Then Exit Sub
If Check_Setup(Ws) = False Then GoTo Cleanup
Set Pvt = Ws.PivotTables(1)
ptrows = Pvt.RowRange.Rows.Count
If Pvt.ColumnGrand = True Then ptrows = ptrows - 1
If ptrows > 1 Then
Set rNotesChanged = Intersect(Rng, _
Range(sRngName))
Else: Set rNotesChanged = Nothing
End If
If rNotesChanged Is Nothing Then Exit Sub
'Limited edits to only one row to prevent program slow down with large ranges and lots of comment columns.
'Check if area being edited is only in one row, and if the comment will show up beside data, or row headers.
'Prevented the comment from appearing twice (once at the top with the header and once at the bottom with the subtotal)
If rNotesChanged.Rows.Count = 1 And Cells(rNotesChanged.Rows(1).Row, Range(sRngName).Columns(1).Column - 1 - GapColumns).Value <> "" Then
Call Update_Note_Database( _
PT:=Pvt, _
rNote:=Intersect(rNotesChanged.EntireRow, Range(sRngName)))
Else
Call Refresh_Notes(Pvt)
End If
Cleanup:
Set rNotesChanged = Nothing
End Sub
