Out of Memory Error when running Drill Down Script

Question

The purpose of the macro is to avoid creating a new worksheet each time a user double clicks / drills down on a pivot table value. Instead the script copies the data to a dedicated "DrillDown" sheet.

After several clicks, I get an Excel error stating I am out of memory.

The raw dataset is not very big.
I am wondering if there is an issue with the script, or perhaps I need to add something further?
Maybe there is some temp data I need to clear first?

My code:

Module1

Public CS$

This Workbook

Private Sub Workbook_NewSheet(ByVal Sh As Object)
If CS <> "" Then
    With Application
        ScreenUpdating = False
        Dim NR&
        With Sheets("DrillDown")

            'Set this to always start at the top of the page
            NR = 1
            '..and to clear the Drilldown tab..
            .Cells.ClearContents

            'instead of this..
            'If WorksheetFunction.CountA(.Rows(1)) = 0 Then
            '   NR = 1
            'Else
            '   NR = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 2
            'End If

            Range("A4").CurrentRegion.Copy .Cells(NR, 1)

        End With
        .DisplayAlerts = False
        ActiveSheet.Delete
        .DisplayAlerts = True
        'Below is commented out to stop user being returned to Pivot
        ' Sheets(CS).Select
    .ScreenUpdating = True
    End With
End If
End Sub

Answer 1

It could be the event triggers while the data is still being written to the sheet. You could retain the newly created sheet and delete the previous to avoid copying.

Private Sub Workbook_NewSheet(ByVal Sh As Object)

    If CS = "" Then Exit Sub
    With Application
        .DisplayAlerts = False
        On Error Resume Next
        Sheets("DrillDown").Delete
        Sh.Name = "DrillDown" ' renamenew sheet
        On Error GoTo 0
        .DisplayAlerts = True
    End With
   
End Sub