Need macro excel to show data on change of heading

Deleted 

Here is a more dynamic version.

Private Sub Worksheet_Change(ByVal Target As Range)
    ' Change if you move the cell where you enter Table 1 or Table 2
    Const OutputRow = 26
    Dim r As Long
    Dim c As Long
    Dim s As String
    Dim i As Long
    Dim r0 As Long
    Dim c0 As Long
    Dim m0 As Long
    Dim users As New Collection
    Dim dates As New Collection
    If Not Intersect(Range("A" & OutputRow), Target) Is Nothing Then
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Range("A" & OutputRow).CurrentRegion.Offset(1).Clear
        Select Case Range("A" & OutputRow).Value
            Case "Table 1"
                c0 = 1
            Case "Table 2"
                c0 = 8
        End Select
        m0 = Cells(2, c0).End(xlDown).Row
        On Error Resume Next
        For r0 = 3 To m0
            users.Add Item:=Cells(r0, c0 + 4).Value, Key:=Cells(r0, c0 + 4).Value
            dates.Add Item:=Cells(r0, c0 + 5).Value, Key:=CStr(Cells(r0, c0 + 4).Value)
        Next r0
        On Error GoTo 0
        For r = 1 To users.Count
            Cells(OutputRow + r + 1, 1).Value = users(r)
        Next r
        For c = 1 To dates.Count
            Cells(OutputRow + 1, c + 1).Value = "Items"
            Cells(OutputRow + users.Count + 2, c + 1).Value = dates(c)
        Next c
        For r = 1 To users.Count
            For c = 1 To dates.Count
                s = ""
                i = 0
                For r0 = 3 To m0
                    If Cells(r0, c0 + 4).Value = users(r) And Cells(r0, c0 + 5).Value = dates(c) Then
                        i = i + 1
                        s = s & vbLf & i & ". " & Cells(r0, c0 + 2).Value
                    End If
                Next r0
                If s <> "" Then
                    Cells(r + OutputRow + 1, c + 1).Value = Mid(s, 2)
                End If
            Next c
        Next r
        Range("A" & OutputRow + 1).Resize(users.Count + 2, dates.Count + 1).Borders.LineStyle = xlContinuous
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End Sub