Self-Cleaning Pivot Table

[reharris2]

I am creating a self-cleaning pivot table that automatically deletes drill down worksheets by asking the user to "Remove this text to preserve this worksheet". The worksheet is supposed to have the phrase appear at the top. If the phrase is not removed, then once the user switches tab the worksheet is deleted. When I drill down on my pivot table, the new worksheet does not have the phrase at the top. Below is the code:


Private Sub Workbook_SheetBeforeDoubleClick( _
ByVal Sh As Object, ByVal Target _
As Range, _
Cancel As Boolean)

Dim curCell As String, ptname As String, a As Integer

Start:
If ActiveSheet.PivotTables.Count = 0 Then GoTo NoPT

On Error GoTo NoPT
If IsEmpty(Target) And ActiveCell.PivotField.Name <> "" Then
Cancel = True
GoTo NoPT
End If
mSheet = ActiveSheet.Name
curCell = ActiveCell.Address
ptname = Sh.Range(curCell).PivotTable

If ActiveSheet.PivotTables(ptname).EnableDrilldown Then
Selection.ShowDetail = True
Rows("1:2").Select
Selection.Insert Shift:=xlDown
Range("a1").Select
Selection.Value = _
"Remove this text to preserve this worksheet."
mSheet = ActiveSheet.Name
Else
a = MsgBox("Enable Drill Down is turned off. " & _
"oould you like to enable it?", vbYesNo, _
"Drill Down Error...")
If a = vbYes Then
ActiveSheet.PivotTables(ptname).EnableDrilldown = True
GoTo Start
Else
Cancel = True
End If
End If

NoPT:
On Error GoTo 0

End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)


Dim mDisAlerts As Boolean

If mSheet <> ActiveSheet.Name Then
On Error Resume Next
If Worksheets(mSheet).Range("A1") = _
"Remove this text to preserve this worksheet." Then

mDisAlerts = Application.DisplayAlerts
If mDisAlerts Then
Application.DisplayAlerts = False
End If

Worksheets(mSheet).Delete
Application.DisplayAlerts = mDisAlerts
End If
On Error GoTo 0
End If
End Sub