Memory leakage in VBA macro

Question

I have written a macro that is supposed to open and close thousands of workbooks and take the information from these. It fills up the list in sheet2 and when it reaches row 50000 it calls a cleaning macro which sorts the data in sheet1. The macro seems to be working fine except for the memory consumption which keeps increasing until Excel tells me it has run out of it. I have tried implementing a workbook save every time the cleaner macro gets called as it seemed to have helped someone else on the forum with the same problem, but for me it did nothing. Does anyone have any ideas to fix this? I have included my code below.

Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim rc As Long
Dim wbRC As Long
Dim rs As Variant


On Error Resume Next


''Optimize Macro Speed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

myPath = "C:\Users\QQQ\Documents\Macro testing\BoM_ALL\"
myExtension = "*.xlsx"

'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
Do While myFile <> ""
    If Worksheets(2).Range("A50000").Value <> "" Then
        Call Cleaner
    End If

    'Set variable equal to opened workbook
    Set wb = Workbooks.Open(Filename:=myPath & myFile)

    'DO stuff in opened wb ------------------------------------------------------------------
    wb.Worksheets(1).Activate
    Range("B:B,D:D,E:E").Select
    Selection.Delete Shift:=xlToLeft
    ActiveSheet.Range("a1").CurrentRegion.Select

    wbRC = Selection.Rows.Count
    rs = Application.Match(Range("C3").Value, ThisWorkbook.Worksheets(3).Range("A1:A66950"), 0)

    If Application.IsNumber(rs) Then
        Range("C2:C" & wbRC).Value = ThisWorkbook.Worksheets(3).Cells(rs, 2).Value

        Selection.AutoFilter
        ActiveSheet.Range("A1:C" & wbRC).AutoFilter Field:=2, Criteria1:=Array( _
            "1", "2", "3", "4", "5", "6", "A", "B"), Operator:=xlFilterValues
        Range("A1").Offset(1, 0).Select
        Range(Selection, Selection.End(xlToRight)).Select
        Range(Selection, Selection.End(xlDown)).Select


        Selection.Copy
        ThisWorkbook.Worksheets(2).Activate
        If Range("A1").Value = "" Then
            Range("A1").Select
        Else
            ActiveSheet.Range("a1").End(xlDown).Offset(1, 0).Select
        End If
        ActiveSheet.Paste
        ActiveSheet.Range(Selection.Address).RemoveDuplicates Columns:=Array(1), Header:=xlNo
    End If

    'Close Workbook
    wb.Application.CutCopyMode = False
    wb.Close SaveChanges:=False

    'Get next file name
    myFile = Dir
Loop
Call Cleaner
'Message Box when tasks are completed
MsgBox "Task Complete!"

'ResetSettings:
'Reset Macro Optimization Settings
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub



Sub Cleaner()

Dim rng1 As Range
Dim rng2 As Range
Dim cell As Range
Dim y As Variant
Dim ri As Long
Dim ci As Integer


Set rng1 = Worksheets(1).Range("A:A")
Set rng2 = Worksheets(2).Range("A:A")

Worksheets(1).Activate
ActiveSheet.Range("a1").CurrentRegion.Select
ri = Selection.Rows.Count
Range("A1").Select

For Each cell In rng2
    If cell.Value = "" Then
        ThisWorkbook.Worksheets(2).Activate
        ActiveSheet.Range("a1").CurrentRegion.Select
        Selection.Delete
        ThisWorkbook.Save
        Exit Sub
    End If
    'y = row location of match
    y = Application.Match(cell.Value, rng1, 0)
    'if not a match then write in the new machine number
    If Not Application.IsNumber(y) Then
        Cells(ri + 1, 1) = cell.Value
        Cells(ri + 1, 2) = cell.Offset(0, 2).Value
        ri = ri + 1
    'if mat number exists then write machine number in a new column
    Else
        ci = 2

        Do While True
            If Cells(y, ci).Value <> "" Then
                If Cells(y, ci).Value = cell.Offset(0, 2).Value Then
                    Exit Do
                End If
            Else
                Cells(y, ci) = cell.Offset(0, 2).Value
                Exit Do
            End If
            ci = ci + 1
        Loop
    End If
Next
ThisWorkbook.Worksheets(2).Activate
ActiveSheet.Range("a1").CurrentRegion.Select
Selection.Delete
ThisWorkbook.Save
End Sub

Answer 1

For your information about error handling (as @Pᴇʜ noted). Your On Error Resume Next swallows error in this line:

rs = Application.Match( _ Range("C3").Value, _ ThisWorkbook.Worksheets(3).Range("A1:A66950"), _ 0)

When value is not found, the error is thrown. Then you test whether rs contains error. But the problem is that for the reader of your code it's not clear that Match throws error when value is not found!

But my point is wider. Having top-level On Error Resume Next is dangerous because if error is thrown and then swallowed (like in case of rs), the program continues to execute in fault state!

Here's the illustration of my point.

Let's take two distinct actions:

1. Searching for value with Match (as you do)
2. Copying filtered range to some place.

All steps are described in comments.

You will be surprised that the filtered range won't be copied, but there will be message "No rows were filtered"!

Source range:

VBA code:

Sub F()

    Dim rs As Variant
    Dim rng As Range
    Dim rngVisible As Range
    Dim rngData As Range

    '// Top-level error handling
    On Error Resume Next

    '// The whole table
    Set rng = Range("A1").CurrentRegion

    '// Table without a header
    With rng
        Set rngData = .Offset(1).Resize(.Rows.Count - 1)
    End With

    '// Search for non-existing value to generate error
    rs = WorksheetFunction.Match("PK", rng.Columns(1), 0)

    '// Filter by existing value
    rng.AutoFilter Field:=1, Criteria1:="DE"
    '// SpecialCells can throw error if there are no visible cells.
    '// Thus, we must check whether we have error!
    Set rngVisible = rngData.SpecialCells(xlCellTypeVisible)
    If Err = 0 Then
        '// Good - there are some visible rows
        rngVisible.Copy Range("E1")
    Else
        '// Message speaks for itself
        MsgBox "No rows were filtered!", vbCritical
    End If

    rng.Parent.AutoFilterMode = False

End Sub

The conclusion: set error handling as close as possible to the "dangerous" code.

Source workbook with code

Answer 2

I have not found any direct error in your code but I guess 50K calls may be to much for Excel VBA. I would try the following tricks:

1. Try to avoid .Select. xlToRight and xlDown may be cheating, too. You can use e.g. Range(Cells(2, 1), Cells( Activesheet.usedrange.Rows, Activesheet.usedrange.columns)).Copy

2. Put your loop - the code between do while and loop - into a Sub. VBA will release all vars and objects when exiting from the sub.

3. Never believe in the success of an IO operation. Check Err.Number every time after IO op. E.g.

   Do While True
       Thisworkbook.Save
       If Err.Number = 0 then Exit Do
   Loop
   

   Apart from this, 50K opens and saves may result in a large amount of outstanding IO operations that may lead to crash.

EDITED ON PEH'S COMMENT

3.a A safer but more complex solution to manage excess IO and avoid endless loops:

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds as Long) 'For 32 Bit Systems
Dim iErr As Integer

For i=1 to 10
    On Error Resume Next        ' turn on rigth before an anticipated error
    Thisworkbook.Save
    If Err.Number = 0 then Exit For
    On Error Goto 0             ' turn off when you expect no more error
    Sleep (100)             ' wait 0.1 second
Next
If Err.Number <> 0 Then     ' if error after 10 tries then it must be something else
    iErr = Err.Number
    Err.Raise iErr
    ....

Of course this is a first shot, you should fine tune sleep time and number of times.

Answer 3

I once had the same problem where I had to update 1000nds of files and I ended up writing a wrapper-script (I would suggest to use VB-Script) to start Excel and trigger the macro to process a reasonable number of files. After that, Excel is completely closed and for the next iteration, a new Excel instance is opened.

In the macro, you have to keep track about which files you already processed, for example by writing a complete list of files into a sheet before starting the first iteration and write a flag like "processed" next to the file when it is handled.

This is a small example I tried. It is calling a function DoSomeOfTheWork that returns true if the work is completed (so that the VB-Script is not stuck in an endless loop). Script and Excel live in the same folder.

' Get Path of script
dim strPath, p
strPath = Wscript.ScriptFullName
p = inStrRev(Wscript.ScriptFullName, "\")
strPath = left(strPath, p)

' Loop until work is complete
dim allDone
allDone = false
do while not allDone
    dim objExcel, objWB
    Set objExcel = CreateObject("Excel.Application")
    set objWB = objExcel.Workbooks.Open(strPath & "\test1.xlsm")
    allDone = objWB.Application.Run("module1.DoSomeOfTheWork")
    ' For Debugging: MsgBox "Done? " & allDone
    objWB.close true
    objExcel.Application.Quit
    Set objExcel = Nothing
loop