Out of Memory Error when running VBA Drill Down Script-CodePudding

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

The issue I am having is after several clicks, I get an Excel error stating I am out of memory. The raw data set is not very big, so 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?

I am a noob with VBA, so your assistance will be appreciated!

Something to note, this is a Power Pivot table.

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

CodePudding user response：

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