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]

Hi Jerry,
I think the root cause for the data not being restored correctly is that France has dates in the pivot but the dates get stored as numbers. For example 18-Sept-12 becomes 41170. I have the same problem with my pivot. As soon as I change to general format, it restores correctly. But my users need to see the actual date in the pivot not the general number. Is there a way the storing could happen in actual date format?

Perhaps it would be better to store and retrieve the values using the unformatted sourcenames. That way if someone changes the displayed number format it should still work.

Try making this modification...

Private Function GetKey(rPC As Range, vFields As Variant) As String
    Dim i As Long
    Dim sNew As String
    
    With rPC.PivotCell.RowItems
        For i = LBound(vFields) To UBound(vFields)
            If i > .Count Then sNew = "" Else sNew = .Item(i).[B][COLOR="#0000CD"]SourceName[/COLOR][/B]
            GetKey = GetKey & sNew & "|"
        Next i
    End With
 End Function

 

[Mr_magana]

Hello Jerry,

Thanks for the code! I tweaked it to work with 4 columns and works like a charm!

However I need a change that didnt manage to implement myself and maybe would be useful as well for Linda85.

Two of my four columns needs to have number format with to decimals X.XX and the others absolute number X. Would be possible to change the code so formatting the Columns in the Dashboard|Notes
sheets updates the format in the pivot table notes?

Thanks again for this code, its very, very useful

 

[XLing]

There is a much more simple way to annotate pivot tables which I just came up with after pulling my hair out. Simply create another worksheet with the categorized item names in column 1 and your comments on those categories in column 2. On your worksheet with the pivot table, perform a vlookup in a new column to the right of your pivot table. It will dynamically keep up as you filter and drill-down.

...XLing

 

[azarij]

Hi XLing,

Would you be able to attach an Excel file showing this approach?

Thank you.

 

[30percent]

Hi Jerry,

I wonder if you could instruct me how to:
a) add more columns for comments
b) and change the title of those columns

on the code.

I tried to manipulate the code but didn't come out right.

Thank you!!

 

[Hatrick40]

I found something under a different site and it appears to be EXACTLY what were looking for.

If you download the tutorial, it will show each step with screenshots.

Pivot4U Excel Add-in - Edit Pivot Tables in Excel Directly

I'm hoping one of you might be able to recreate this without having to purchase the software.

 

[USAFexcelguy]

Hi All,

The code provided here is seriously cool! Respect to the author!
I was playing with the code and have a couple of question re that.
I have a pivot table dynamically updating from raw data sheet. The thing with current VBA code presented here is that it creates the unique key phrase using all pivot table fields in one row.
Is it possible to change the code in such a way that it would only use one pivot table field as key phrase?
Due to the nature of the data I'm processing using this pivot table, one field in it will always be unique, but others are constantly changing.
if it's possible, how do I do that?

I strongly suspect I need to change the following code parts:

'---Build formula to use as Match KeyPhrase

'---Match KeyPhrases for each visible row of PT

but I can't figure out what exactly needs to be changed there.

Any help will be greatly appreciated!


Alex

Hello all and thank you Jerry for this thread! It's the only thing I've found that came close to answering my question! I'm having the same problem as Alex where my pivot table is composed data that comes from multiple different sources. It's basically a manning document that matches names to position numbers within our organization. That data has already been combined in Access, but the names change quite often while the position numbers remain the same. So just like Alex, I need to be able to add notes to my pivot table that stay with the position number, while allowing the other information in the same row as that position number to remain the same.

Bottom line, how do I change the code to use the position number column as my key phrase instead of the current data from the entire row?

Thank you!

Jacob

 

[Kirnon]

Hi,

This code is phenomenal - I figured it would be possible. I also knew that I would never be able to do it myself.

Thanks.

I do have a small issue that seems to be occuring (Not game breaking at all) Comments put into a row heading (non-tablular) is copied in the total row too. Any idea why?

 

[Danskheart]

Hi all! This thread is amazing! I'm new(er) to VBA, and I've been trying to modify this code to work with multiple(11) notes columns, but I can't quite seem to get it to work. Everything works except for the bit where it creates the row in the notes table ~ instead of assigning each note to its respective column, it will only write to the first column.

Any ideas? I've posted my code below.

Option Explicit

 
Public Const sRngName = "PT_Notes"


 
Public Function Check_Setup(ws As Worksheet) As Boolean
    Dim rNotes As Range, i As Long, bCompact As Boolean
    Dim PT As PivotTable, ptField As PivotField
    Dim tblNotes As ListObject
    Dim wsSave As Worksheet


 
'---Check if not exactly one PT on Worksheet- exit
    If ws.PivotTables.Count <> 1 Then GoTo StopNotes
    Set PT = ws.PivotTables(1)


'---Check if not at least one RowField and one DataField- exit
    If PT.DataFields.Count = 0 Or PT.RowFields.Count = 0 Then GoTo StopNotes




'---Check if Named Range "PT_Notes" doesn't exist- define it
    If Not NameExists(sRngName, ws.Name) Then
        With PT.TableRange1
            Set rNotes = Intersect(PT.DataBodyRange.EntireRow, _
                    .Resize(, 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) = "Note1"
            .Cells(1, 3) = "Note2"
            .Cells(1, 4) = "Note3"
            .Cells(1, 5) = "Note4"
            .Cells(1, 6) = "Note5"
            .Cells(1, 7) = "Note6"
            .Cells(1, 8) = "Note7"
            .Cells(1, 9) = "Note8"
            .Cells(1, 10) = "Note9"
            .Cells(1, 11) = "Note10"
            .Cells(1, 12) = "Note11"
            Set tblNotes = .ListObjects.Add(xlSrcRange, _
                .Range("A1:L2"), , 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
        .Font.Size = 10
        .HorizontalAlignment = xlLeft
        .IndentLevel = 1
    End With




'---Format optional header
    With rNotes.Resize(1).Offset(-1)
        .Cells(1).Value = "Note1"
        .Cells(2).Value = "Note2"
        .Cells(3).Value = "Note3"
        .Cells(4).Value = "Note4"
        .Cells(5).Value = "Note5"
        .Cells(6).Value = "Note6"
        .Cells(7).Value = "Note7"
        .Cells(8).Value = "Note8"
        .Cells(9).Value = "Note9"
        .Cells(10).Value = "Note10"
        .Cells(11).Value = "Note11"
        .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(, 11).Offset(0, .Columns.Count))
    End With
    Set rNotes = rNotes.Resize(rNotes.Rows.Count + PT.ColumnGrand)
    PT.Parent.Names(sRngName).RefersTo = rNotes
    Call Format_NoteRange(rNotes)
 
'---Make array of rowfields by position to trace each row in hierarchy
     With PT.RowFields
        ReDim vFields(1 To .Count)
        For lIdx = 1 To .Count
            vFields(PT.RowFields(lIdx).Position) = PT.RowFields(lIdx).Name
        Next lIdx
    End With


'---Build formula to use as Match KeyPhrase
    Set tblNotes = Sheets(PT.Parent.Name & "|Notes").ListObjects(1)
    With tblNotes
        On Error Resume Next
        sFormula = "="
        For lIdx = LBound(vFields) To UBound(vFields)
            lCol = Application.Match(vFields(lIdx), .HeaderRowRange, 0)
            sFormula = sFormula & "RC" & lCol & "&""|""&"
        Next lIdx
        sFormula = Left(sFormula, Len(sFormula) - 1)
        Intersect(.DataBodyRange, .ListColumns(1).Range).FormulaR1C1 = sFormula
    End With


'---Match KeyPhrases for each visible row of PT
    Application.EnableEvents = False
    With PT.TableRange1
        lOffset = .Column + .Columns.Count - PT.DataBodyRange.Column + 1
    End With


    With PT.DataBodyRange.Resize(, 1)
        For lRow = 1 To .Rows.Count + PT.ColumnGrand
            sKey = GetKey(rPC:=.Cells(lRow), vFields:=vFields)
            vReturn = Evaluate("=MATCH(""" & _
                sKey & """," & tblNotes.Name & "[KeyPhrase],0)")
            If (Not IsError(vReturn)) Then
                .Cells(lRow, lOffset) = Evaluate("=INDEX(" & tblNotes.Name & "[Note1]," & vReturn & ")")
                .Cells(lRow, lOffset + 1) = Evaluate("=INDEX(" & tblNotes.Name & "[Note2]," & vReturn & ")")
                .Cells(lRow, lOffset + 2) = Evaluate("=INDEX(" & tblNotes.Name & "[Note3]," & vReturn & ")")
                .Cells(lRow, lOffset + 3) = Evaluate("=INDEX(" & tblNotes.Name & "[Note4]," & vReturn & ")")
                .Cells(lRow, lOffset + 4) = Evaluate("=INDEX(" & tblNotes.Name & "[Note5]," & vReturn & ")")
                .Cells(lRow, lOffset + 5) = Evaluate("=INDEX(" & tblNotes.Name & "[Note6]," & vReturn & ")")
                .Cells(lRow, lOffset + 6) = Evaluate("=INDEX(" & tblNotes.Name & "[Note7]," & vReturn & ")")
                .Cells(lRow, lOffset + 7) = Evaluate("=INDEX(" & tblNotes.Name & "[Note8]," & vReturn & ")")
                .Cells(lRow, lOffset + 8) = Evaluate("=INDEX(" & tblNotes.Name & "[Note9]," & vReturn & ")")
                .Cells(lRow, lOffset + 9) = Evaluate("=INDEX(" & tblNotes.Name & "[Note10]," & vReturn & ")")
                .Cells(lRow, lOffset + 10) = Evaluate("=INDEX(" & tblNotes.Name & "[Note11]," & vReturn & ")")
            End If
        Next lRow
    End With
    Application.EnableEvents = True
End Function




Private Function GetKey(rPC As Range, vFields As Variant) As String
    Dim i As Long
    Dim sNew As String
    
    With rPC.PivotCell.RowItems
        For i = LBound(vFields) To UBound(vFields)
            If i > .Count Then sNew = "" Else sNew = .Item(i).Caption
            GetKey = GetKey & sNew & "|"
        Next i
    End With
 End Function


Public Function Update_Note_Database(PT As PivotTable, rNote As Range)
    Dim tblNotes As ListObject
    Dim rPC As Range
    Dim iArray As Variant, i As Integer
 
    '---Make new record of note at top of database table
    Set tblNotes = Sheets(PT.Parent.Name & "|Notes").ListObjects(1)
    tblNotes.ListRows.Add (1)
    tblNotes.ListColumns("Note1").Range(2) = rNote(, 1).Value
    tblNotes.ListColumns("Note2").Range(2) = rNote(, 2).Value
    tblNotes.ListColumns("Note3").Range(2) = rNote(, 3).Value
    tblNotes.ListColumns("Note4").Range(2) = rNote(, 4).Value
    tblNotes.ListColumns("Note5").Range(2) = rNote(, 5).Value
    tblNotes.ListColumns("Note6").Range(2) = rNote(, 6).Value
    tblNotes.ListColumns("Note7").Range(2) = rNote(, 7).Value
    tblNotes.ListColumns("Note8").Range(2) = rNote(, 8).Value
    tblNotes.ListColumns("Note9").Range(2) = rNote(, 9).Value
    tblNotes.ListColumns("Note10").Range(2) = rNote(, 10).Value
    tblNotes.ListColumns("Note11").Range(2) = rNote(, 11).Value
    
    Set rPC = Intersect(PT.DataBodyRange.Resize(, 1), rNote.EntireRow)
    With rPC.PivotCell.RowItems
        For i = 1 To .Count
            With .Item(i)
                tblNotes.ListColumns(.Parent.Name).Range(2) = .Caption
            End With
        Next i
    End With




'---Remove any previous notes with matching rowfield values
    With tblNotes.Range
        ReDim iArray(0 To .Columns.Count - 13)
        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 = "" And rNote(1, 2).Value = "" And rNote(1, 3).Value = "" And rNote(1, 4).Value = "" And rNote(1, 5).Value = "" And rNote(1, 6).Value = "" And rNote(1, 7).Value = "" And rNote(1, 8).Value = "" And rNote(1, 9).Value = "" And rNote(1, 10).Value = "" And rNote(1, 11).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

 

[Jerry Sullivan]

Hi Danskheart,

There's a few fixes that you'll need to do to your code.

In Function Format_NoteRange, this needs to be something like...

   With rNotes.Resize(1).Offset(-1)
        .Cells(1,1).Value = "Note1"
        .Cells(1,2).Value = "Note2"
        .Cells(1,3).Value = "Note3"

You followed the pattern that I used in Post #19, but that was incorrect (I'm surprised I didn't test that code before posting).

Rather than having those repetitive statements, try using a For...Next loop to iterate through the 11 columns.

That Function Format_NoteRange should also have statements that temporarily disable events.

'--at beginning of function
Application.EnableEvents= False

'---body of code
'.....
'.....
'.....
'--at end of function
Application.EnableEvents= True

You'll also need to modify this part of Function Check_Setup(ws As Worksheet)....

'---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(, [B][COLOR="#0000CD"]11[/COLOR][/B]).Offset(0, .Columns.Count))
        End With