Macro Running Out Of Memory When Run Twice

Question

I am new to this forum but have been reading a large number of posts recently as I am currently self teaching VBA for use at work!

I currently am having an issue with a bit of code that I have created. The aim of the code is to autofilter multiple sheets depending on a cell value that is double clicked on, it then copies these filtered results to another "Master Report" sheet. The issue is that it runs perfectly fine once, after which if I try to run it again or any of my other macro's within the workbook an error pops up asking me to close things to free up memory!

I have tried running the macro once, saving and closing the workbook (to clear anything that might be cached), re-opening and running and yet the same error persists. I also tried changing my .select prompts with .activate as suggested by:

How to avoid running out of memory when running VBA

but that seemed to break my code... then again I may have just implemented it wrong as I am a bit of a VBA noob Can anyone help me optimize my code to prevent this?

my code is as below:

Private Sub Merge()
With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    Selection.Merge
End Sub

-------------------------------------------------------------------------------------------------------------------------------------------------------

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = True
Application.ScreenUpdating = False
Application.EnableEvents = False
Sheets("Master Report").Cells.Delete 'clear old master report
Column = Target.Column
Row = Target.Row

'this automatically filters information for a single part and creates a new master report with summary information
PartNumber = Cells(Row, 2).Value 'capture target part number for filtering
PartDesc = Cells(Row, 7).Value 'capture target part description
PartNumberWildCard = "*" & PartNumber & "*" 'add wildcards to allow for additional terms
    With Worksheets("NCR's") 'filter NCR sheet
        .Select
        On Error Resume Next
        ActiveSheet.ShowAllData 'remove any previous filters
        On Error GoTo 0
        .Range("A1").AutoFilter Field:=2, Criteria1:=PartNumberWildCard
    End With
Sheets("NCR's").Select
Sheets("NCR's").Range("A3:K3").Select
Sheets("NCR's").Range(Selection, Selection.End(xlDown)).Select 'select NCR filtered summary info
Selection.Copy
Sheets("Master Report").Select
Sheets("Master Report").Range("A1").Formula = PartNumber
Sheets("Master Report").Range("D1").Formula = PartDesc 'Print part no. & description at top of master report
Sheets("Master Report").Range("A4").Select
ActiveSheet.Paste 'paste filtered NCR info into master report
Sheets("Master Report").Range("A3:K3").Select
Call Merge
ActiveCell.FormulaR1C1 = "NCR's"

With Worksheets("CR's") 'filter CR sheet
        .Select
        On Error Resume Next
        ActiveSheet.ShowAllData 'remove any previous filters
        On Error GoTo 0
        .Range("A1").AutoFilter Field:=3, Criteria1:=PartNumberWildCard
    End With
Sheets("CR's").Select
Sheets("CR's").Range("A7:F7").Select
Sheets("CR's").Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Master Report").Select
Sheets("Master Report").Range("P4").Select
ActiveSheet.Paste
Sheets("Master Report").Range("RP3:U3").Select
Call Merge
ActiveCell.FormulaR1C1 = "CR's"

With Worksheets("PO's") 'filter PO sheet
        .Select
        On Error Resume Next
        ActiveSheet.ShowAllData 'remove any previous filters
        On Error GoTo 0
        .Range("A1").AutoFilter Field:=2, Criteria1:=PartNumberWildCard
    End With
Sheets("PO's").Select
Sheets("PO's").Range("A3:H3").Select
Sheets("PO's").Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Master Report").Select
lastRow = Sheets("Master Report").Range("A" & Rows.Count).End(xlUp).Row
lastRow = lastRow + 3
Sheets("Master Report").Range("A" & lastRow).Select
ActiveSheet.Paste
Sheets("Master Report").Range("A" & lastRow - 1 & ":H" & lastRow - 1).Select
Call Merge
ActiveCell.FormulaR1C1 = "PO's"
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Another piece of info that may help is that I tried removing the last of the three filter/copy/paste routines, this allowed me to run the code about 3 times before running into the same memory error. Also the Debugger always gets stuck on the command to clear the master report at the beginning of the macro

Sheets("Master Report").Cells.Delete 'clear old master report

I would also add at the end of your macro `Application.CutCopyMode=False` to clear the clipboard. — Tim Wilkinson, Nov 16 '16 at 16:04
[Avoid using `.Select`](http://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba-macros), that can cause slow downs and errant behavior if you're not careful — BruceWayne, Nov 16 '16 at 17:51

Tim Wilkinson · Answer 1 · 2016-11-16T16:33:20.483

There are a couple of tips to speed up your macro and make it use less memory (less selecting, copying pasting). For a start it would be better to loop through your sheets rather than one long script for every one.

Dim arrShts As Variant, arrSht As Variant
arrShts = Array("NCR's", "CR's", "PO's")
For Each arrSht In arrShts
    Worksheets(arrSht).Activate
    'rest of your code'
Next arrSht

In the array add any other sheets you need to run the script on

Declaring variables is recommended also:

Dim masterws As Worksheet
Set masterws = Sheets("Master Report")

masterws.Activate
masterws.Range("A1").Formula = PartNumber

I haven't been able to do this 100% accurately, but you could limit your code down to something like the following

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Application.ScreenUpdating = False
Application.EnableEvents = False
Column = Target.Column
Row = Target.Row

PartNumber = Cells(Row, 2).Value 'capture target part number for filtering
PartDesc = Cells(Row, 7).Value 'capture target part description
PartNumberWildCard = "*" & PartNumber & "*" 'add wildcards to allow for additional terms

Dim arrShts As Variant, arrSht As Variant, lastrw As Integer
Dim masterws As Worksheet
Set masterws = Sheets("Master Report")

masterws.Cells.Clear 'clear old master report
arrShts = Array("NCR's", "CR's", "PO's")

For Each arrSht In arrShts
    Worksheets(arrSht).Activate
    lastrw = Sheets(arrSht).Range("K" & Rows.Count).End(xlUp).Row
    With Worksheets(arrSht) 'filter NCR sheet
        On Error Resume Next
        ActiveSheet.ShowAllData 'remove any previous filters
        On Error GoTo 0
        .Range("A1").AutoFilter Field:=2, Criteria1:=PartNumberWildCard
    End With

    Range(Cells(3, 1), Cells(lastrw, 11)).Copy
    lastRow = Sheets("Master Report").Range("A" & Rows.Count).End(xlUp).Row

    masterws.Activate
    masterws.Range("A1").Formula = PartNumber
    masterws.Range("D1").Formula = PartDesc 'Print part no. & description at top of master report
    masterws.Range("A" & lastRow).PasteSpecial xlPasteValues
    masterws.Range("A" & lastRow - 1 & ":H" & lastRow - 1).Select
    Call Merge
    ActiveCell.FormulaR1C1 = arrSht
    Application.CutCopyMode = False
Next arrSht

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

This is in no way complete, and will edit as I find bits, but a good place to start to reduce the strain of your macro.

I will give this a go! Only reason why I did not try this previously is that different sheets sometimes require multiple filter criterion and the information gets pasted in different places. The code you pasted above would paste the information into the master report in a vertical list which is fine but I am unsure how to solve the different number of filter criterion issue — C_Harris, Nov 16 '16 at 16:34
If that is the case you can just define a different filter criteria depending on the sheet name `If arrSht = "NCR's" Then PartNumberWildCard = *something for this sheet*` — Tim Wilkinson, Nov 16 '16 at 16:37
It isnt that the partnumber changes, its that the defined fields for the autofiltering change. For example in NCR i only filter in field 2, but in PO's I filter in field 2 & 3 — C_Harris, Nov 16 '16 at 16:46
You can modify that clip to be for your fields instead of the PartNumberWildCard — Tim Wilkinson, Nov 17 '16 at 13:24

score 1 · Accepted Answer · answered Nov 16 '16 at 17:19

try this refactoring of your code

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean)
    Dim iRow As Long
    Dim PartNumber As String, PartDesc As String, PartNumberWildCard As String
    Dim masterSht As Worksheet

    Set masterSht = Worksheets("Master Report")

    cancel = True
    iRow = Target.Row

    PartNumber = Cells(iRow, 2).Value 'capture target part number for filtering
    PartDesc = Cells(iRow, 7).Value 'capture target part description
    PartNumberWildCard = "*" & PartNumber & "*" 'add wildcards to allow for additional terms

    'clear old master report and write headers
    With masterSht
        .Cells.ClearContents
        .Cells.UnMerge
        .Range("A1").Value = PartNumber
        .Range("D1").Value = PartDesc 'Print part no. & description at top of master report

        FilterAndPaste "NCR's", "K1", 2, PartNumberWildCard, .Range("A4")

        FilterAndPaste "CR's", "F1", 3, PartNumberWildCard, .Range("P4")

        FilterAndPaste "PO's", "H1", 2, PartNumberWildCard, .Cells(rows.count, "A").End(xlUp).Offset(3)
    End With
End Sub


Sub FilterAndPaste(shtName As String, lastHeaderAddress As String, fieldToFilter As Long, criteria As String, targetCell As Range)
    With Worksheets(shtName)
        .AutoFilterMode = False 'remove any previous filters
        With .Range(lastHeaderAddress, .Cells(.rows.count, 1).End(xlUp))
            .AutoFilter Field:=fieldToFilter, Criteria1:=criteria
            If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then
                .Resize(.rows.count - 1).Offset(1).SpecialCells(XlCellType.xlCellTypeVisible).Copy Destination:=targetCell
                With targetCell.Offset(-1).Resize(, .Columns.count)
                    Merge .Cells
                    .Value = shtName
                End With
            End If
        End With
    End With
End Sub

Private Sub Merge(rng As Range)
    With rng
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .Merge
    End With
End Sub

should it work for you, as it did in my tests, then I can add you some info, if you care about

Hi, this seemed to work great! I dont quite understand whats going on in the FilterandPaste sub. It doesnt paste my headers into the master report. Also how would I modify it so that it would search for the part number in the PO's sheet in field 2 or 3? — C_Harris, Nov 17 '16 at 14:13
I figured out how to include headers but am still unsure as to this section of the code: `If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then .Resize(.Rows.Count - 1).SpecialCells(XlCellType.xlCellTypeVisible).Copy Destination:=targetCell With targetCell.Offset(-1).Resize(, .Columns.Count)` — C_Harris, Nov 17 '16 at 14:18

Macro Running Out Of Memory When Run Twice

2 Answers2