VBA Memory Leak?

[MrRodger]

Hi All,

Im not sure if I can attach the whole file as an example but I have described my VBA setup below. Any VBA help to identify and correct my memory usage issues would be greatly appreciated!

I have a SharePoint site that has hundreds of Excel files stored on it and I interact with them via mapped drives. Each file connects to a database somewhere (Linked tables, data connections etc...) and needs to be refreshed periodically. To do this I have tried to write some VBA that accomplishes a few things, one checks if a file is locked for editing on the server by another user (to skip the file if its locked) and two, if the file is not locked then to update all data connections in the file before saving and closing.

This worked well in the past on traditional linked tables but now that we are using files with PowerQuery and Pivot Models the vba is crashing due to the system running out of memory. I think this is due to a VBA memory leak as my RAM usage increases as the VBA iterates through files one by one until a memory crash takes place.

I am unsure how to go about correcting my code or if this is even possible to fix.

Declarations

Option Explicit 'forces code to be declared to avoid issues and speed up the code
'Created (With help from the internet) by Chris Bischel, Senior Evaluation Manager at City Year Los Angeles 4/25/16.
'To run properly you neet to go to tools>references> and check Microsoft Scripting Runtime
'To use with external networks (Non local folders) map your network to a local drive letter (http://kb.netgear.com/app/answers/detail/a_id/19864/~/how-do-i-map-a-network-drive-in-windows%3F?cid=wmt_netgear_organic)
'Note: The selected folder must have subfolders to be updated. Files within a parent folder will be skipped if not within subfolders :/
'Below are the delcared variables that we need to get things working


' Option Explicit Written by Philip Treacy March 2015
' http://www.myonlinetraininghub.com/pausing-or-delaying-vba-using-wait-sleep-or-a-loop
#If VBA7 Then ' Excel 2010 or later
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)
    Public Declare PtrSafe Function GetTickCount Lib "kernel32" () As LongPtr
    
Dim WB As Workbook, mypath As String, msg As String, myExtension As String 'for checking filetypes
Dim FileName As String 'for Filelocked function
Dim Response As Integer, StartTime As Double, MinutesElapsed As String 'for timer
Dim FSO As Scripting.FileSystemObject, FF As Scripting.Folder, SubF As Scripting.Folder, F As Scripting.File 'for folders and subfolders
Dim FolderPath As String, Fldr_name As String 'to pass off cell value
Dim Printvalue As String 'test log


#Else ' Excel 2007 or earlier
    Public Declare Sub Sleep Lib "kernel32" (ByVal Milliseconds As Long)
    Public Declare Function GetTickCount Lib "kernel32" () As Long
    
Dim WB As Workbook, mypath As String, msg As String, myExtension As String 'for checking filetypes
Dim FileName As String 'for Filelocked function
Dim Response As Integer, StartTime As Double, MinutesElapsed As String 'for timer
Dim FSO As Scripting.FileSystemObject, FF As Scripting.Folder, SubF As Scripting.Folder, F As Scripting.File 'for folders and subfolders
Dim FolderPath As String, Fldr_name As String 'to pass off cell value
Dim Printvalue As String 'test log
#End If

VBA to launch macros in sequence

Public Sub Update_Launcher() 'starts the update process


If Sheet2.Range("E2").Value = "" Then 'If the mapped drive location is blank
MsgBox "Please map a drive letter and run again.", vbOKOnly
Else 'If there is a value then


Call ClearLog 'resets the log for the current update cycle
StartTime = Timer 'Set the timer equal to start time


Sheet2.[A15].Formula = "=Now()" 'Record the start timestamp via the now function, then copy/paste it.
Sheets("Update").Select
Range("A15:C15").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Call Update_Databases 'See below macro
DoEvents 'waits until called macro finishes


If Sheet2.Range("J13").Value = "No" Then
Else


Call Update_Subfolders ' calls macro to update all subfolders on mapped drive
DoEvents 'waits until called macro finishes


    'Determine how many seconds code took to run
    MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
    'Notify user when other macros finish
    Application.ScreenUpdating = True
    Application.AskToUpdateLinks = True 'reactivated when all done
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    
    Sheets("Update").Select 'records the finishing timestamp to log update cycle duration
    Range("A14:C14").Select
    ActiveCell.FormulaR1C1 = "=NOW()"
    Range("A14:C14").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False


ThisWorkbook.Save 'saves the updater
ThisWorkbook.Close
Application.Quit 'closes the updater
End If 'for end if mapped drive letter missing
End If


    Sheets("Update").Select 'records the finishing timestamp to log update cycle duration
    Range("A14:C14").Select
    ActiveCell.FormulaR1C1 = "=NOW()"
    Range("A14:C14").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False


End Sub

Loop through subfolders (I suspect these loops may be part of my issue...)

Sub Update_Subfolders()
Fldr_name = Sheets("Update").Range("E2").Value 'grabs folder directory from cell value
    Set FSO = New Scripting.FileSystemObject
    Set FF = FSO.Getfolder(Fldr_name) 'map drive to parent folder for Sharepoint. change as needed
    For Each SubF In FF.Subfolders 'For each subfolder in the filesystem object
        Update_Current_Folder SubF 'for every subfolder run the macro below
    Next SubF
End Sub

Update files within subfolders loop

Sub Update_Current_Folder(FF As Scripting.Folder)
    
    For Each F In FF.Files 'for each file in the subfolders
        Application.AskToUpdateLinks = False 'Skips external links (which is different than linked tables)
        Application.DisplayAlerts = False 'Skips external links (which is different than linked tables
        Application.EnableEvents = False 'to prevent execution of other macros
        Application.Calculation = xlCalculationAutomatic 'Sets calcualtion to automatic on each file
    mypath = Sheets("Update").Range("E9").Value 'sets the type of file to be updated
    If UCase(F.Name) Like (mypath) Then 'Only work on specified workbooks
    If FileLocked(F.Path) Then 'Calls the function below checking if the file is locked by another user. (A must for sharepoint)
        Else
        On Error GoTo myerror 'error handling that skips to specific line
        Set WB = Workbooks.Open(F.Path) 'open the workbook at the given string
    If ActiveWorkbook.ReadOnly Then 'When accessing files off primary network connection you need this extra step to edit files
        WB.LockServerFile 'Grants exclusive edit rights to file
        WB.RefreshAll 'updates all external connections (exculdes links because you should never use links.... ever)
        DoEvents
        WasteTime (2) 'new method of wait time
        WB.Save
        WB.Close
        WasteTime (2) 'new method of wait time
    Else 'otherwise if open pushes through to edit automatically (typically done via CY internet)
        WB.RefreshAll    'refreshes all connections in current workbook
        DoEvents    'waits until refresh action is complete
        WasteTime (2) 'new method of wait time
        WB.Save
        WB.Close
        WasteTime (2) 'new method of wait time
    End If ' for if file read only
    End If
        Application.AskToUpdateLinks = True 'to avoid broken links errors caused by macs.
        Application.DisplayAlerts = True
        
        Application.EnableEvents = True 'Turns on events
        Application.ScreenUpdating = True 'allows us to see whats happening once its all done
        Application.Calculation = xlCalculationAutomatic 'automatically calculates before save
myerror: 'handles any unexpected issues with message box prompts.
If Err <> 0 Then
    Resume Next
    End If
        Printvalue = F.Name 'variable to export to log
        Debug.Print FF & "\" & F.Name 'prints to immidate window
    If Sheets("UpdateLog").Range("A2") = "" Then
        Sheets("UpdateLog").Cells(Rows.Count, 1).End(xlUp).Offset(0) = F.Name
        Sheets("UpdateLog").Cells(Rows.Count, 2).End(xlUp).Offset(0) = Now()
    Else
        Sheets("UpdateLog").Cells(Rows.Count, 1).End(xlUp).Offset(1) = F.Name
        Sheets("UpdateLog").Cells(Rows.Count, 2).End(xlUp).Offset(0) = Now()
        End If 'for the updatelog
        End If 'refering to If fileextension
    Next F
    
    For Each SubF In FF.Subfolders 'subfolder catch
        Update_Current_Folder SubF
    Next SubF
    'Application.EnableCancelKey = xlInterrupt
End Sub

Function to check if server file is locked

Function FileLocked(strFileName As String) As Boolean
    On Error Resume Next
    ' If the file is already opened by another process,
    ' and the specified type of access is not allowed,
    ' the Open operation fails and an error occurs.
    Open strFileName For Binary Access Read Write Lock Read Write As #1
    Close #1
    ' If an error occurs, the document is currently open.
    FileLocked = IIf(Err.Number = 0, False, True)
    'Application.EnableCancelKey = xlInterrupt
    On Error GoTo 0
End Function

Function to wait until PowerQuery models update

Sub WasteTime(Finish As Long) 'macro that stalls while powerquery loads
    Dim NowTick As Long 'start CPU tick
    Dim EndTick As Long 'end CPU tick
    EndTick = GetTickCount + (Finish * 1000)
    Do
        NowTick = GetTickCount
        DoEvents
    Loop Until NowTick >= EndTick
End Sub