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!

 

[Jerry Sullivan]

I tried copy and pasting the code above, created a tab called PT Notes and tried running the code. It gives an error at the 1st step

"

Public Const sRngName = "PT_Notes"

​

---

​

It could be one of a few things.

1. You don't need to create a worksheet called PT_Notes. That's the name of a named range that is created by the code.

2. Make sure that you have copied the code into the correct Sheet Code and Standard Code Modules as described above.

3. This code should be the first code pasted in each module. If you try to put the declaration: Public Const sRngName = "PT_Notes"
after another procedure it will generate an error.

4. To "run" the code, just enter a note in the first column to the right of the PivotTable. The code is then automatically triggered. You can't run the Worksheet_Change event code like an ordinary macro.

 

[Stacy A]

Hi Jerry,


The codes you posted above appear be the solution I've been seeking for several weeks! My only problem is that my pivot table has to be in tabular form. I purchased the MrExcel VBA and Marcros book to see if I could edit the code to work for a tabular table vs. compact, but I'm quickly realizing that your code is more complex than I'm ready to tackle. Is it even possible to make this change, and if so, would you be willing to help me determine what needs to be done?

Thanks,
Stacy

p.s. I don't plan to give up on learning to write/edit my own code... I think I'm hooked! ... I'm just facing a deadline and smart enough to know when I'm out of my league.

 

[Jerry Sullivan]

Hi Stacy,

Yes, it's easy to get hooked. Fortunately, this Forum is great resource for learning.

I'll try to help if I can. The part of the code that will need to be adapted is the part that traces the hierchy of RowFields that are associated with a given row of the Report. In some ways, that should be easier to do with a Tabular Layout than the Compact Layout, but in other ways it's harder.

What version of Excel are you using?
If you are using Excel 2010, are you using the "Repeat Row Labels" for all your fields?

I'll try to make this work regardless of whether 2010 Repeat Row Labels is being used; but if that proves difficult, I'll start with your scenario.

 

[Stacy A]

I'm using Excel 2007, but our company hasn't finished upgrading everyone yet, so I have to initially create the report in 2003 compatibility mode (to my dismay) and will eventually update it to a 2007 format when all of the upgrades are completed. I've set it up to have 9 row labels (displayed horizontally across columns) and 2 columns of values. We will be using filters on the row label fields to sort the report for various user groups, which is what drives my need to keep text tied to moving data. Let me know if there is any other info you need. I truly appreciate your assistance!

Thanks,
Stacy

 

[Jerry Sullivan]

Stacy,

I've taken a pass at modifying the code so that it will work with either Tabular, Outline or Compact Report Layouts.

As I advised the original poster, miconian, this code should be tested extensively prior to using it for a real world application (and even then make sure to have a back up of your file).

Paste all of this code into a Standard Code Module...

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(, 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
    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(, 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
    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("=INDEX(" & tblNotes.Name & "[Note],MATCH(""" & _
                sKey & """," & tblNotes.Name & "[KeyPhrase],0))")
            If (Not IsError(vReturn)) Then .Cells(lRow, lOffset) = CStr(vReturn)
        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_Tabular(PT As PivotTable, rNote As Range)
    Dim rLabels As Range
    Dim tblNotes As ListObject
    Dim lCol As Long
    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("Note").Range(2) = rNote.Value
    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
   
'---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


 
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
 
    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
        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
    Else    '--Tabular or Outline layout
        Set tblNotes = Sheets(PT.Parent.Name & "|Notes").ListObjects(1)
        tblNotes.ListRows.Add (1)
        tblNotes.ListColumns("Note").Range(2) = rNote.Value
        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 - 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

Then paste this code into the Sheet Code Module of the Worksheet that has the PivotTable to be annotated.

Option Explicit


Private Sub Worksheet_Change(ByVal Target As Range)
'----When changes are made in the named range displaying
'--    PivotTable Notes, the Note database table
'--    will be updated with each New or Revised note.
 
    Dim rNotesChanged As Range, c As Range
 
    Application.ScreenUpdating = False
    If Check_Setup(Me) = False Then GoTo CleanUp
    Set rNotesChanged = Intersect(Target, _
        Range(sRngName))
    If rNotesChanged Is Nothing Then Exit Sub
    For Each c In rNotesChanged
        Call Update_Note_Database( _
            PT:=Me.PivotTables(1), _
            rNote:=c)
    Next c
CleanUp:
    Set rNotesChanged = Nothing
    Application.EnableEvents = True
    Application.ScreenUpdating = True
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 Check_Setup(Me) = False Then Exit Sub
 
    Application.ScreenUpdating = False
    Application.EnableEvents = False
 
    Call Refresh_Notes(PT:=Target)
 
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[France Desjardins]

Hi Jerry,

I was so happy to find this VBA code and I followed every step neatly, didn't work, srapped the file, started over and finally I was able to enter comment in the first right row of the pivot table. The column generated itself and it created a new ''Notes'' tab in my workbook where all my comments are stored.

The comments in the new ''Notes'' tab stay there; but when I refresh my pivot, or save, exit and then reopen the file they disapear from the Notes column.

Any help would be greatly appreciated.

Sincerely,
France using Excel 2007

Excel 2007

	A	B	C	D	E	F	G	H	I
RSM	SALESGROUP	QUOTATIONID	QUOTE CAT	CREATED	FOLLOWUPDATE	CUSTOMERREF	Total
AV	INT	SQ_014104		27-Sep-12	25/10/2012 0:00	15 Renwick
		SQ_014076		20-Sep-12	18/10/2012 0:00	Marilyn Monroe Spas - National Account
		SQ_014052		18-Sep-12	11/10/2012 0:00	Roosevelt Hospital
		SQ_014013		4-Sep-12	02/10/2012 0:00	Cambria Suites, NY
		SQ_013991		28-Aug-12	25/09/2012 0:00	Goodmart
		SQ_013980		24-Aug-12	21/09/2012 0:00	Columbus Towers, NY
		SQ_013953	SPEC REG	20-Aug-12	17/09/2012 0:00	Barnes Noble HQ, Palo Alto CA
		SQ_013952		20-Aug-12	17/09/2012 0:00	75 Pine Residences
				17-Sep-12	17/09/2012 0:00	75 Pine Residences
		SQ_013932		16-Aug-12	13/09/2012 0:00	Morrison Residence, NY
		SQ_013910		8-Aug-12	04/09/2012 0:00	13th Street Residential Development

<tbody>
[TD="align: center"]3
[/TD]

[TD="bgcolor: #F8F8F8, align: center"]Notes
[/TD]

[TD="align: center"]4
[/TD]

[TD="align: center"]$37,832
[/TD]
[TD="bgcolor: #F8F8F8"][/TD]

[TD="align: center"]5
[/TD]

[TD="align: center"]$1,584
[/TD]
[TD="bgcolor: #F8F8F8"][/TD]

[TD="align: center"]6
[/TD]

[TD="align: center"]$107,700
[/TD]
[TD="bgcolor: #F8F8F8"][/TD]

[TD="align: center"]7
[/TD]

[TD="align: center"]$59,446
[/TD]
[TD="bgcolor: #F8F8F8"][/TD]

[TD="align: center"]8
[/TD]

[TD="align: center"]$500
[/TD]
[TD="bgcolor: #F8F8F8"][/TD]

[TD="align: center"]9
[/TD]

[TD="align: center"]$729,684
[/TD]
[TD="bgcolor: #F8F8F8"][/TD]

[TD="align: center"]10
[/TD]

[TD="align: center"]$2,618
[/TD]
[TD="bgcolor: #F8F8F8"][/TD]

[TD="align: center"]11
[/TD]

[TD="align: center"]$70,680
[/TD]
[TD="bgcolor: #F8F8F8"][/TD]

[TD="align: center"]12
[/TD]

[TD="align: center"]$150,000
[/TD]
[TD="bgcolor: #F8F8F8"][/TD]

[TD="align: center"]13
[/TD]

[TD="align: center"]$47
[/TD]
[TD="bgcolor: #F8F8F8"][/TD]

[TD="align: center"]14
[/TD]

[TD="align: center"]$52,500
[/TD]
[TD="bgcolor: #F8F8F8"][/TD]

</tbody>

Open Quotes
Excel 2007

	A	B	C	D	E	F	G	H	I
KeyPhrase	RSM	FOLLOWUPDATE	CUSTOMERREF	SALESGROUP	CREATED	QUOTE CAT	QUOTATIONID	Note
AV|INT|SQ_014052||41170|41193|Roosevelt Hospital|	AV	Roosevelt Hospital	INT	SQ_014052	ghi
AV|INT|SQ_014076||41172|41200|Marilyn Monroe Spas - National Account|	AV	Marilyn Monroe Spas - National Account	INT	SQ_014076	def
AV|INT|SQ_014104||41179|41207|15 Renwick|	AV	15 Renwick	INT	SQ_014104	abc
AV|INT|SQ_013991||41149|41177|Goodmart|	AV	Goodmart	INT	SQ_013991
AV|INT|SQ_014013||41156|41184|Cambria Suites, NY|	AV	Cambria Suites, NY	INT	SQ_014013
SST|LMAX|SQ_013382||40973|41001|Rex Art Residence, Miami FL|	SST	Rex Art Residence, Miami FL	LMAX	SQ_013382	SQ_013382
SST|LMAX|SQ_013402||40976|41004|Rosa Clara - Miami|	SST	Rosa Clara - Miami	LMAX	SQ_013402	SQ_013402
SST|LMAX|SQ_013479||40995|41023|Morse Life Short Term Rehab|	SST	Morse Life Short Term Rehab	LMAX	SQ_013479	SQ_013479
SST|LMAX|SQ_013642|SPEC REG|41045|41073|McCann Erickson|	SST	McCann Erickson	LMAX	SPEC REG	SQ_013642	SQ_013642
SST|LMAX|SQ_013684||41059|41087|Vizcayne Towers|	SST	Vizcayne Towers	LMAX	SQ_013684	SQ_013684
SST|LMAX|SQ_013750||41080|41108|LS Lighting Systems / Display|	SST	LS Lighting Systems / Display	LMAX	SQ_013750	SQ_013750
SST|LMAX|SQ_013792||41088|41116|Luxe Cable + Light|	SST	Luxe Cable + Light	LMAX	SQ_013792	SQ_013792
SST|TSC|SQ_009422||40199|40227|Trios, Charleston SC|	SST	Trios, Charleston SC	TSC	SQ_009422	SQ_009422
SST|TSC|SQ_009713|SPEC REG|40260|40288|Temple Beth EL Renovation, Charlotte NC|	SST	Temple Beth EL Renovation, Charlotte NC	TSC	SPEC REG	SQ_009713	SQ_009713
SST|TSC|SQ_010332||40372|40400|Anderson College, Anderson SC|	SST	Anderson College, Anderson SC	TSC	SQ_010332	SQ_010332
SST|TSC|SQ_014089||41176|41204|Rick Hendrick Chevrolet, Charleston SC|	SST	Rick Hendrick Chevrolet, Charleston SC	TSC	SQ_014089	SQ_014089

<colgroup><col><col><col><col><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
[TD="align: center"]1[/TD]

[TD="align: center"]2[/TD]

[TD="align: right"]########[/TD]

[TD="align: right"]18-Sep-12[/TD]
[TD="align: right"][/TD]

[TD="align: center"]3[/TD]

[TD="align: right"]########[/TD]

[TD="align: right"]20-Sep-12[/TD]
[TD="align: right"][/TD]

[TD="align: center"]4[/TD]

[TD="align: right"]########[/TD]

[TD="align: right"]27-Sep-12[/TD]
[TD="align: right"][/TD]

[TD="align: center"]5[/TD]

[TD="align: right"]########[/TD]

[TD="align: right"]28-Aug-12[/TD]
[TD="align: right"][/TD]

[TD="align: right"]13991[/TD]

[TD="align: center"]6[/TD]

[TD="align: right"]########[/TD]

[TD="align: right"]04-Sep-12[/TD]
[TD="align: right"][/TD]

[TD="align: right"]1409[/TD]

[TD="align: center"]7[/TD]

[TD="align: right"]########[/TD]

[TD="align: right"]05-Mar-12[/TD]
[TD="align: right"][/TD]

[TD="align: center"]8[/TD]

[TD="align: right"]########[/TD]

[TD="align: right"]08-Mar-12[/TD]
[TD="align: right"][/TD]

[TD="align: center"]9[/TD]

[TD="align: right"]########[/TD]

[TD="align: right"]27-Mar-12[/TD]
[TD="align: right"][/TD]

[TD="align: center"]10[/TD]

[TD="align: right"]########[/TD]

[TD="align: right"]########[/TD]

[TD="align: center"]11[/TD]

[TD="align: right"]########[/TD]

[TD="align: right"]########[/TD]
[TD="align: right"][/TD]

[TD="align: center"]12[/TD]

[TD="align: right"]########[/TD]

[TD="align: right"]20-Jun-12[/TD]
[TD="align: right"][/TD]

[TD="align: center"]13[/TD]

[TD="align: right"]########[/TD]

[TD="align: right"]28-Jun-12[/TD]
[TD="align: right"][/TD]

[TD="align: center"]14[/TD]

[TD="align: right"]########[/TD]

[TD="align: right"]21-Jan-10[/TD]
[TD="align: right"][/TD]

[TD="align: center"]15[/TD]

[TD="align: right"]########[/TD]

[TD="align: right"]23-Mar-10[/TD]

[TD="align: center"]16[/TD]

[TD="align: right"]########[/TD]

[TD="align: right"]13-Jul-10[/TD]
[TD="align: right"][/TD]

[TD="align: center"]17[/TD]

[TD="align: right"]########[/TD]

[TD="align: right"]24-Sep-12[/TD]
[TD="align: right"][/TD]

</tbody>

Open Quotes|Notes​

[TABLE="width: 85%"]
<tbody>[TR]
[TD]Worksheet Formulas[TABLE="width: 100%"]
<thead>[TR="bgcolor: #E0E0F0"]
[TH="width: 10"]Cell[/TH]
[TH="align: left"]Formula[/TH]
[/TR]
</thead><tbody>[TR]
[TH="width: 10, bgcolor: #E0E0F0"]A2[/TH]
[TD="align: left"]=$B2&"|"&$E2&"|"&$H2&"|"&$G2&"|"&$F2&"|"&$C2&"|"&$D2&"|"[/TD]
[/TR]
[TR]
[TH="width: 10, bgcolor: #E0E0F0"]A3[/TH]
[TD="align: left"]=$B3&"|"&$E3&"|"&$H3&"|"&$G3&"|"&$F3&"|"&$C3&"|"&$D3&"|"[/TD]
[/TR]
[TR]
[TH="width: 10, bgcolor: #E0E0F0"]A4[/TH]
[TD="align: left"]=$B4&"|"&$E4&"|"&$H4&"|"&$G4&"|"&$F4&"|"&$C4&"|"&$D4&"|"[/TD]
[/TR]
[TR]
[TH="width: 10, bgcolor: #E0E0F0"]A5[/TH]
[TD="align: left"]=$B5&"|"&$E5&"|"&$H5&"|"&$G5&"|"&$F5&"|"&$C5&"|"&$D5&"|"[/TD]
[/TR]
[TR]
[TH="width: 10, bgcolor: #E0E0F0"]A6[/TH]
[TD="align: left"]=$B6&"|"&$E6&"|"&$H6&"|"&$G6&"|"&$F6&"|"&$C6&"|"&$D6&"|"[/TD]
[/TR]
[TR]
[TH="width: 10, bgcolor: #E0E0F0"]A7[/TH]
[TD="align: left"]=$B7&"|"&$E7&"|"&$H7&"|"&$G7&"|"&$F7&"|"&$C7&"|"&$D7&"|"[/TD]
[/TR]
[TR]
[TH="width: 10, bgcolor: #E0E0F0"]A8[/TH]
[TD="align: left"]=$B8&"|"&$E8&"|"&$H8&"|"&$G8&"|"&$F8&"|"&$C8&"|"&$D8&"|"[/TD]
[/TR]
[TR]
[TH="width: 10, bgcolor: #E0E0F0"]A9[/TH]
[TD="align: left"]=$B9&"|"&$E9&"|"&$H9&"|"&$G9&"|"&$F9&"|"&$C9&"|"&$D9&"|"[/TD]
[/TR]
[TR]
[TH="width: 10, bgcolor: #E0E0F0"]A10[/TH]
[TD="align: left"]=$B10&"|"&$E10&"|"&$H10&"|"&$G10&"|"&$F10&"|"&$C10&"|"&$D10&"|"[/TD]
[/TR]
[TR]
[TH="width: 10, bgcolor: #E0E0F0"]A11[/TH]
[TD="align: left"]=$B11&"|"&$E11&"|"&$H11&"|"&$G11&"|"&$F11&"|"&$C11&"|"&$D11&"|"[/TD]
[/TR]
[TR]
[TH="width: 10, bgcolor: #E0E0F0"]A12[/TH]
[TD="align: left"]=$B12&"|"&$E12&"|"&$H12&"|"&$G12&"|"&$F12&"|"&$C12&"|"&$D12&"|"[/TD]
[/TR]
[TR]
[TH="width: 10, bgcolor: #E0E0F0"]A13[/TH]
[TD="align: left"]=$B13&"|"&$E13&"|"&$H13&"|"&$G13&"|"&$F13&"|"&$C13&"|"&$D13&"|"[/TD]
[/TR]
[TR]
[TH="width: 10, bgcolor: #E0E0F0"]A14[/TH]
[TD="align: left"]=$B14&"|"&$E14&"|"&$H14&"|"&$G14&"|"&$F14&"|"&$C14&"|"&$D14&"|"[/TD]
[/TR]
[TR]
[TH="width: 10, bgcolor: #E0E0F0"]A15[/TH]
[TD="align: left"]=$B15&"|"&$E15&"|"&$H15&"|"&$G15&"|"&$F15&"|"&$C15&"|"&$D15&"|"[/TD]
[/TR]
[TR]
[TH="width: 10, bgcolor: #E0E0F0"]A16[/TH]
[TD="align: left"]=$B16&"|"&$E16&"|"&$H16&"|"&$G16&"|"&$F16&"|"&$C16&"|"&$D16&"|"[/TD]
[/TR]
[TR]
[TH="width: 10, bgcolor: #E0E0F0"]A17[/TH]
[TD="align: left"]=$B17&"|"&$E17&"|"&$H17&"|"&$G17&"|"&$F17&"|"&$C17&"|"&$D17&"|"[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
</tbody>[/TABLE]




​

 

[Jerry Sullivan]

Hi France,

I'm glad that you're interesting in trying this. It's difficult to know what the problem is from your description.
Each time a PivotTable change occurs, the code is supposed to clear the notes then restore them to their new cell locations.
It appears that the code is correctly storing the notes, but not restoring them.

The restore should happen at this part of the Function Refresh_Notes(PT As PivotTable)...

'---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("=INDEX(" & tblNotes.Name & "[Note],MATCH(""" & _
                sKey & """," & tblNotes.Name & "[KeyPhrase],0))")
            If (Not IsError(vReturn)) Then .Cells(lRow, lOffset) = CStr(vReturn)
        Next lRow
    End With

If you have some familiarity with VBA, you could put a Breakpoint in at the first line of code above then use F8 to step through each line to see why those values aren't gettting restored.

There's a chance the code control isn't reaching this point at all, which you could determine with a similar process of stepping through the entire code.

Please let me know what you find out.

 

[codsmith]

Jerry, this is AMAZING code and works great!

I do have one question thought. Is it possible to add a second "notes" column? I've been searching through the code, but so far I can't identify where those changes would occur.

 

[Jerry Sullivan]

Hi codsmith and Welcome to the Board,

Here is a modified version with two columns for notes.

Paste all of this code into a Standard Code Module...

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) = "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
    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 & "[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(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
 
    
    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

    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

Then paste this code into the Sheet Code Module of the Worksheet that has the PivotTable to be annotated.

Option Explicit


Private Sub Worksheet_Change(ByVal Target As Range)
'----When changes are made in the named range displaying
'--    PivotTable Notes, the Note database table
'--    will be updated with each New or Revised note.
 
    Dim rNotesChanged As Range, c As Range
 
    Application.ScreenUpdating = False
    If Check_Setup(Me) = False Then GoTo CleanUp
    Set rNotesChanged = Intersect(Target, _
        Range(sRngName))
    If rNotesChanged Is Nothing Then Exit Sub
    For Each c In rNotesChanged
        Call Update_Note_Database( _
            PT:=Me.PivotTables(1), _
            rNote:=Intersect(c.EntireRow, Range(sRngName)))
    Next c
CleanUp:
    Set rNotesChanged = Nothing
    Application.EnableEvents = True
    Application.ScreenUpdating = True
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 Check_Setup(Me) = False Then Exit Sub
 
    Application.ScreenUpdating = False
    Application.EnableEvents = False
 
    Call Refresh_Notes(PT:=Target)
 
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[codsmith]

This works perfectly! Thank you so much Jerry!!!!!!!!!!!!!!!

--Cody