how to annotate pivot tables?

[miconian]

My users spend a lot of time in large pivot tables that are set up in compact view, expanding and collapsing fields by clicking on the plus and minus symbols. As they do this, they want to make notes about individual line items.

However, this is difficult because a) there is nowhere that allows the user to make notes inside the pivot table, and b) if they make notes outside the table, the row their note corresponds to will change when fields are collapsed and expanded. Also, it seems that Excel does not allow comments to be added to cells within pivot tables.

Surely others have had this problem. Is there some obvious workaround I'm missing?

thanks!

 

[gman1991]

Hello!

Jerry, I know this thread is a couple of years in age but your code is exactly what I have been searching for! However, I am having a few hiccups that prevent me from executing it. I keep running into the error "Run-time error '13': Type mismatch" which later asks me to debug the bolded line within the code-

 With PT.RowFields        ReDim vFields(1 To .Count)
        For lIdx = 1 To .Count
[B]            vFields(PT.RowFields(lIdx).Position) = PT.RowFields(lIdx).Name[/B]
        Next lIdx
    End With

I am not sure what within my pivot table is causing this error and I'm hoping for some insight as to how to go about solving this. Thank you!

 

[giogomez]

Jerry, thanks! This is awesome. Sorry it works perfectly 2 years later!

 

[giogomez]

*So it works perfectly 2 years later!

 

[cpinder24]

This code is amazing and has saved me so much time!

Thank you for the work on it!

Callum

 

[Dash3]

This is awesome, thank you so much !!!

 

[Daryl K]

I know this thread is 5+ years old but I was looking for a way to add a Notes / Comments column to a pivot table and came across Jerry's code and am amazed how well it fit my needs. I only needed some minor tweaking to the formatting and it works beautifully.

Thanks Jerry - your old work is still helping folks out!

 

[AnthonyKing8787]

I have been using this comment module for a year and it has been extraordinarily useful. Throughout using it I have slowly edited / evolved it slightly, and thought that I should post the code that I am now using.

Hopefully this helps someone. Apologies if I have missed any details or haven't sufficiently commented on any portion. Please don't hesitate to post improvements or better comments if you notice they are needed anywhere.

Here is an overview of the changes I have made:

- Main change was to how the "KeyPhrase" column works. Rather than changing the formula to match the order found in the pivot table, I kept the KeyPhrase formula the same regardless of how many RowItems there were or what order they were in. This way, comments don't get lost when RowItems are swapped, removed, or added.

- The other major change was to allow multiple columns, and for the number of columns to be changed dynamically from the top of the CommentModule.

Other minor changes:

- I put the worksheet code in it's own module for easier maintenance. I was calling from 30+ worksheets and every time I went to edit I had to edit each worksheet separately.
- When comment columns are added, the old comment columns and comments will be preserved
- Works for multiple PivotTable formats, whether subtotals or grandtotals are included, etc.
- Hid the Comments tab from the user

Here is the code:

This is the Main code that I have put in Module 1

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 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))
        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))
        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))
    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) = 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).Caption
                    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.Name).Range(2) = .Caption
            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

This is the Worksheet module with the code that gets called on WorksheetChange Event. I post it in Module 2

Option Explicit


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).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

Finally, this is the code that I put in every sheet that includes a PivotTable to annotate

Option Explicit


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).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

 

[AnthonyKing8787]

Seems I messed up above and posted the Module 2 code twice, replacing the code that goes in the Worksheet module that hosts the Pivot Table. My apologies.

Let's try again...

Module 1:

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 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))
        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))
        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))
    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) = 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).Caption
                    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.Name).Range(2) = .Caption
            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

Module 2:

Option Explicit


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).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

Worksheet with Pivot Table Module:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Call WorksheetChanges(Target, Me)
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
'----Refreshes display of PivotTable Notes from the Note database
'--    when the PivotTable is updated (refreshed, sorted, filtered, etc)
    If ActiveSheet.Name <> Me.Name Then
        Exit Sub
    Else: End If
    If Check_Setup(Me) = False Then Exit Sub
 
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
 
    Call Refresh_Notes(PT:=Target)
 
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub

 

[stlpony]

This thread is utterly amazing. I've been struggling with how to manage something similar my organization wants to do. Going to dig into this in a few weeks.

 

[tjr3191]

Seems I messed up above and posted the Module 2 code twice, replacing the code that goes in the Worksheet module that hosts the Pivot Table. My apologies.

Let's try again...

This code works great, but I'm pretty new at using VBA... how could I alter this for four columns of notes?

Thanks!