How can I open this VBA book faster?

Question

I'm currently trying to make a macro that goes into the directory, open the workbook (currently 38 of them end up being 52), filter out two columns, get the total (repeat this 4 times) and close the book. The application currently takes about 7 minutes to process the current 38 books.

How can I speed this up? I already turned off screen updates, events, and I changed the calculation methods to xlCalculationManual. I don’t know if this was common practice, but I saw people asking about how to access the workbook without opening it, but the proposal to turn off the screen update is always fulfilled, which I did.

When I run it in debug mode, Workbooks.Open () can take up to 10 seconds. The file directory is actually located on the company’s network, but access to the file, as a rule, rarely takes 5 seconds.

Data in books may contain the same points, but with a different status. I do not think that combining all the data into one book would be possible.

I am going to experiment with direct cell references. As soon as I get some results, I will update my post.

Private UNAME As String Sub FileOpenTest() Call UserName Dim folderPath As String Dim filename As String Dim tempFile As String Dim wb As Workbook Dim num As Integer Dim values(207) As Variant Dim arryindex Dim numStr As String Dim v As Variant Dim init As Integer init = 0 num = 1 arryindex = 0 numStr = "0" & CStr(num) 'Initialize values(x) to -1 For Each v In values values(init) = -1 init = init + 1 Next With Excel.Application .ScreenUpdating = False .Calculation = Excel.xlCalculationManual .EnableEvents = False .DisplayAlerts = False End With 'File path to save temp file tempFile = "C:\Users\" & UNAME & "\Documents\TEMP.xlsm" 'Directory of weekly reports folderPath = "path here" 'First file to open filename = Dir(folderPath & "file here" & numStr & ".xlsm") Do While filename <> "" Set wb = Workbooks.Open(folderPath & filename) 'Overwrite previous "TEMP.xlsm" workbook without alert Application.DisplayAlerts = False 'Save a temporary file with unshared attribute wb.SaveAs filename:=tempFile, AccessMode:=xlExclusive 'operate on file Filters values, arryindex wb.Close False 'Reset file name filename = Dir 'I use this loop to add the appropriate number to the end ie 01, 02, 03 etc If num >= 9 Then num = num + 1 If num = 33 Then num = num + 1 End If numStr = CStr(num) ElseIf num < 9 Then num = num + 1 numStr = "0" & CStr(num) End If filename = Dir(folderPath & "filename here" & numStr & ".xlsm") Loop output values 'Delete "TEMP.xlsm" file On Error Resume Next Kill tempFile On Error GoTo 0 End Sub Function Filters(ByRef values() As Variant, ByRef arryindex) On Error Resume Next ActiveSheet.ShowAllData On Error GoTo 0 'filter column1 ActiveSheet.Range("B6").End(xlDown).AutoFilter Field:=2, Criteria1:=Array( _ "p1", "p2", "p3", "p4", "p5"), Operator:=xlFilterValues 'filter column2 ActiveSheet.Range("J6").End(xlDown).AutoFilter Field:=10, Criteria1:=Array( _ "s1", "d2", "s3"), Operator:=xlFilterValues 'get the total of points values(arryindex) = TotalCount arryindex = arryindex + 1 'filter column2 for different criteria ActiveSheet.Range("J6").End(xlDown).AutoFilter Field:=10, Criteria1:="s" 'filter colum3 for associated form ActiveSheet.Range("AZ6").End(xlDown).AutoFilter Field:=52, Criteria1:="<>" 'get the total of points values(arryindex) = TotalCount arryindex = arryindex + 1 'filter coum 3 for blank forms ActiveSheet.Range("AZ6").End(xlDown).AutoFilter Field:=52, Criteria1:="=" 'get the total of points values(arryindex) = TotalCount arryindex = arryindex + 1 'filter for column4 if deadline was made ActiveSheet.Range("J6").End(xlDown).AutoFilter Field:=52 ActiveSheet.Range("J6").End(xlDown).AutoFilter Field:=10, Criteria1:=Array( _ "s1", "s2", "s3", "s4", "s5", "s6"), Operator:=xlFilterValues ActiveSheet.Range("BC6").End(xlDown).AutoFilter Field:=55, Criteria1:=RGB(146 _ , 208, 80), Operator:=xlFilterCellColor 'get total of points values(arryindex) = TotalCount arryindex = arryindex + 1 End Function Public Function TotalCount() As Integer Dim rTable As Range, r As Range, Kount As Long Set rTable = ActiveSheet.AutoFilter.Range TotalCount = -1 For Each r In Intersect(Range("A:A"), rTable) If r.EntireRow.Hidden = False Then TotalCount = TotalCount + 1 End If Next End Function Function UserName() As String UNAME = Environ("USERNAME") End Function Function output(ByRef values() As Variant) Dim index1 As Integer Dim index2 As Integer Dim t As Range Dim cw As Integer 'Calendar week declariations Dim cwstart As Integer Dim cstart As Integer Dim cstop As Integer Dim data As Integer data = 0 start = 0 cw = 37 cstart = 0 cstop = 3 ThisWorkbook.Sheets("Sheet1").Range("B6").Activate For index1 = start To cw For index2 = cstart To cstop Set t = ActiveCell.Offset(rowOffset:=index1, columnOffset:=index2) t.value = values(data) data = data + 1 Next Next End Function 

Answer 1

In general, there are five rules for quickly executing Excel-VBA macros:

• Do not use .Select methods,

• Do not use Active* objects more than once.

• Turn off screen updates and automatic calculations,

• Do not use visual Excel methods (e.g. Search, Autofilter, etc.)

• And, above all, they always use copying arrays with a range, rather than viewing individual cells in a range.

Of these, you just completed # 3. In addition, you exacerbate the situation by repeatedly saving your worksheets, just so that you can perform visual modification methods (AutoFilter in your case). What you need to do to make it fast is to first implement the rest of the rules, and secondly, stop modifying your source tables so that you can open them for reading only.

The core of what causes problems and causing all these other unwanted solutions is how you implemented the Filters function. Instead of trying to do everything with Excel visual functions that are slow compared to (well-written) VBAs (and which modify worksheets to force your redundant Saves), just arrays of arrays copy all the data you need from the worksheet and use direct VBA code for counting.

Here is an example of your Filters function, which I have converted to these principles:

 Function Filters(ByRef values() As Variant, ByRef arryindex) On Error GoTo 0 Dim ws As Worksheet Set ws = ActiveSheet 'find the last cell that we might care about Dim LastCell As Range Set LastCell = ws.Range("B6:AZ6").End(xlDown) 'capture all of the data at once with a range-array copy Dim data() As Variant, colors() As Variant data = ws.Range("A6", LastCell).Value colors = ws.Range("BC6", "BC" & LastCell.Row).Interior.Color ' now scan through every row, skipping those that do not 'match the filter criteria Dim r As Long, c As Long, v As Variant Dim TotCnt1 As Long, TotCnt2 As Long, TotCnt3 As Long, TotCnt4 As Long TotCnt1 = -1: TotCnt2 = -1: TotCnt3 = -1: TotCnt4 = -1 For r = 1 To UBound(data, 1) 'filter column1 (B6[2]) v = data(r, 2) If v = "p1" Or v = "p2" Or v = "p3" Or v = "p4" Or v = "p5" Then 'filter column2 (J6[10]) v = data(r, 10) If v = "s1" Or v = "d2" Or d = "s3" Then 'get the total of points TotCnt1 = TotCnt1 + 1 End If 'filter column2 for different criteria If data(r, 10) = "s" Then 'filter colum3 for associated form If CStr(data(r, 52)) <> "" Then 'get the total of points TotCnt2 = TotCnt2 + 1 Else ' filter coum 3 for blank forms 'get the total of points TotCnt3 = TotCnt3 + 1 End If End If 'filter for column4 if deadline was made v = data(r, 10) If v = "s1" Or v = "s2" Or v = "s3" Or v = "s4" Or v = "s5" Then If colors(r, 1) = RGB(146, 208, 80) Then TotCnt4 = TotCnt4 + 1 End If End If End If Next r values(arryindex) = TotCnt1 values(arryindex + 1) = TotCnt2 values(arryindex + 2) = TotCnt3 values(arryindex + 3) = TotCnt4 arryindex = arryindex + 4 End Function 

Please note that because I cannot verify this for you, and also because there are many indirect consequences for the Autofilter / Range effects in the source code, I cannot say if this is correct. You will have to do this.

Note. If you decide to implement this, let us know what impact it had, if any. (I try to keep track of what works and how much)