excel - How can I open this VBA workbook faster?

Question

I am currently trying to make a macro that will go to a directory, open a workbook (there are 38 currently with an eventual total of 52), filter two columns, get the total (repeat this 4 times), and the close the workbook. Currently it takes my application about 7 minutes just to process the current 38 workbooks.

How can I speed this up? I have already disables screen updating, events, and I changed the calculation methods to xlCalculationManual. I don't know if it common practice but I have seen people asking about a way to access a workbook without it being open but the suggestion to turn off screen updating is always made, which I have done.

When I run it in debug mode the Workbooks.Open() can take up to 10 seconds. The file directory is actually on a company network but accessing the file normally barely takes any time, under 5 seconds.

The data in the workbooks can contain the same points but at a different status. I do not think combining all of the data into one workbook would be possible.

I am going to experiment with direct cell references. Once I have 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 & "DocumentsTEMP.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 to making Excel-VBA macros fast:

1. Don't use .Select methods,

2. Don't use Active* objects more than once,

3. Disable screen-updating and automatic calculations,

4. Don't use visual Excel methods (like Search, Autofilter, etc),

5. And most of all, always use range-array copying instead of browsing individual cells in a range.

Of these, you have only implemented #3. Additionally, you are exacerbating things by re-Saving your worksheets, just so that you can execute Visual modification methods (AutoFilter in your case). What you need to do to make it fast is to first implement the rest of these rules, and secondly, stop modifying your source worksheets so that you can open them read-only.

The core of what's causing your problems and forcing all of these other undesirable decisions is how you have implemented the Filters function. Instead of trying to do everything with the visual Excel functions, which are slow compared to (well-written) VBA (and that modify the worksheets, forcing your redundant Saves), just range-array copy all of the data you need from the sheet and use straight-forward VBA code to do your counting.

Here is an example of your Filters function that I 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 test this for you and also because there is a lot of implicitness to the Autofilter/Range effects in the original code, I cannot tell if it is correct. You will have to do that.

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