Hello everyone,
I have routine that loops through multiple files (around 8000 files) in a folder and checks value of only one cell in the Row2, and if it meets conditions then it copies that row (around 8 cells with data) to master file. Only 0.5% of files meet these criteria, so there is not much data being transferred. The problem is that speed of macros progressively decreases during runtime. If it takes around 5 min to process first 800 files, it takes 1.4 times longer to process second 800 files, and 3.4 times longer to process 6th 800 files. If processing time would not change all the files would be processed within 50 min, instead it takes more than 1 hour to process 60% of files. Somewhere between 50% and 70% workbook crashes without finishing routine. I would be grateful for any help to make routine stable, improve speed of this routine and to fix problem with memory. The code is as it follows below. Table with delay time and images with error messages attached to the post. Thanks in advance.
Sub BuySellSignalsModified()
'PURPOSE: Determine how many seconds it took for code to completely run
<img src="https://www.ozgrid.com/forum/core/index.php?attachment/1229913-computer-performance-png/" class="woltlabAttachment" data-attachment-id="1229913" id="wcfImgAttachment0"><img src="https://www.ozgrid.com/forum/core/index.php?attachment/1229915-runtime-error-png/" class="woltlabAttachment" data-attachment-id="1229915" id="wcfImgAttachment0"><img src="https://www.ozgrid.com/forum/core/index.php?attachment/1229914-out-of-memory-png/" class="woltlabAttachment" data-attachment-id="1229914" id="wcfImgAttachment0"><img src="https://www.ozgrid.com/forum/core/index.php?attachment/1229916-slowdowntime-png/" class="woltlabAttachment" data-attachment-id="1229916" id="wcfImgAttachment0">
Dim StartTime As Double
Dim SecondsElapsed As Double
'Remember time when macro starts
StartTime = Timer
Dim wb As Workbook, ws As Worksheet
Workbooks("MasterFile - Copy.xlsm").Worksheets("MasterSheet").Cells.Clear
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldr = fso.GetFolder("C:\VBA\")
Set DestSh = Workbooks("MasterFile - Copy.xlsm").Worksheets("MasterSheet")
Set DestWb = Workbooks("MasterFile - Copy.xlsm")
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = True '<= do not use or change to True
Application.DisplayAlerts = False
Dim counter As Long '<= added
Dim numFiles As Long '<= added
numFiles = fldr.Files.Count '<= added
For Each wbFile In fldr.Files
Application.StatusBar = "Processing: " & Format(counter / numFiles, "0.000%") & " completed" '<= added
If fso.GetExtensionName(wbFile.Name) = "csv" Then
Set wb = Workbooks.Open(wbFile.Path)
'
Worksheets(1).Activate
Range("I1").Value = "V/SMA10"
Columns("I:I").NumberFormat = "General"
Range("I2").FormulaR1C1 = "=AVERAGE(RC[-1]:R[9]C[-1])"
Range("I2").AutoFill Destination:=Range("I2:I1500")
Range("J1").Value = "Vol/Change%"
Columns("J:J").NumberFormat = "0.00%"
Range("J2").FormulaR1C1 = "=(RC[-2]-RC[-1])/RC[-1]"
Range("J2").AutoFill Destination:=Range("J2:J1500")
Range("K1").Value = "SMA10"
Columns("K:K").NumberFormat = "0.00$"
Range("K2").FormulaR1C1 = "=AVERAGE(RC[-4]:R[9]C[-4])"
Range("K2").AutoFill Destination:=Range("K2:K1500")
Range("L1").Value = "SMA30"
Columns("L:L").NumberFormat = "0.00$"
Range("L2").FormulaR1C1 = "=AVERAGE(RC[-5]:R[29]C[-5])"
Range("L2").AutoFill Destination:=Range("L2:L1500")
Range("M1").Value = "BUY/SELL SMA10 CROSSOVER"
Range("M2").FormulaR1C1 = "=IF(AND(RC[-2]>RC[-1],R[1]C[-2]<R[1]C[-1],RC[-1]>R[1]C[-1]),""BUY"",IF(AND(RC[-7]<RC[-4],R[1]C[-7]>R[1]C[-4]),""SELL"",""""))"
Range("M2").AutoFill Destination:=Range("M2:M120")
Range("O1").Value = "Close/Change%"
Columns("O:O").NumberFormat = "0.00%"
Range("O2").FormulaR1C1 = "=(RC[-8]-R[1]C[-8])/R[1]C[-8]"
Range("O2").AutoFill Destination:=Range("O2:O1500")
ActiveSheet.Columns.AutoFit
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = True
Application.DisplayAlerts = False
For i = 2 To 2
If Worksheets(1).Cells(i, 13).Value = "BUY" Then
ActiveWorkbook.Worksheets(1).Rows(i).Copy
DestSh.Activate
DestRowNumber = DestSh.Cells(Rows.Count, 1).End(xlUp).Row
With DestSh.Cells(DestRowNumber + 1, 1)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
Next
DestSh.Columns.AutoFit
wb.Close True
End If
counter = counter + 1 '<= added
Call ClearClipboard
Next wbFile
Application.StatusBar = False '<= added
Application.ScreenUpdating = True
Application.EnableEvents = True
'Application.DisplayStatusBar = True
Application.DisplayAlerts = True
Application.CutCopyMode = False
'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)
'Notify user in seconds
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
Display More