Macro Running Out Of Memory When Run Twice - excel

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

Answer 1

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.

Answer 2

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