Adding notes to a power pivot table

[BORUCH]

Hi all
I am using the below code to insert notes to the right of my power pivot table

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(, 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
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 & ")")
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(1, 2).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 - 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


Public Function isPivotCell(rCell As Range) As Boolean
On Error Resume Next
isPivotCell = Not (IsError(rCell.PivotCell))
End Function



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
'---Update each changed note cell unless the change was due to
' being overlapped by a resized PivotTable
If Not isPivotCell(c) Then _
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


the problem is that i'm creating a pivot table from a data module and its not working its repeating all the notes to all the lines