4
\$\begingroup\$

I have this simple looping macro, but I can't seem how to figure out how to make it run faster. I tried including more update = false statements as well as well as removing any selecting type behavior.

 Sub AbesLoop()

 Dim wbk As Workbook
 Dim ws As Integer
 Dim Filename As String
 Dim Path As String
 Dim rCell As Range
 Dim rRng As Range
 Dim wsO As Worksheet

 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 Application.Calculation = xlCalculationManual

 Path = "PathToFolder" & "\"
 Filename = Dir(Path & "*.xl??")
 Set wsO = ThisWorkbook.Sheets("Sheet1")

 Do While Len(Filename) > 0
     Set wbk = Workbooks.Open(Path & Filename, True, True)
     ws = wbk.Worksheets.Count
     For i = 1 To ws
     Application.ScreenUpdating = False
     Application.DisplayAlerts = False
     Application.Calculation = xlCalculationManual
     Set rRng = Range("b1:b20")
         For Each rCell In rRng.Cells
             If rCell <> "" And rCell.Value <> "Not Tested" Then

             wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = rCell
             wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 1).Value = rCell.Offset(0, -1)
             wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 2).Value = Right(ActiveWorkbook.FullName, 15)
             End If
         Next rCell
     Next i
     wbk.Close False
     Filename = Dir
 Loop

 Application.ScreenUpdating = True
 Application.DisplayAlerts = True
 Application.Calculation = xlCalculationAutomatic

 End Sub
\$\endgroup\$
  • 3
    \$\begingroup\$ As we all want to make our code more efficient or improve it in one way or another, try to write a title that summarizes what your code does, not what you want to get out of a review. Please see How to get the best value out of Code Review - Asking Questions for guidance on writing good question titles. \$\endgroup\$ – BCdotWEB Feb 29 '16 at 15:02
  • \$\begingroup\$ As is mentioned in the guide @BCdotWEB linked, your title and question should provide a description and overview of what your code is trying to do, why and how. The more we know about what you are trying to achieve, the better the advice we can offer. \$\endgroup\$ – Kaz Feb 29 '16 at 16:51
2
\$\begingroup\$

This answer is just going to focus on what you asked for, how to speed up your code. I'm going to go through line by line and note anything that could be done to make it faster.


 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 Application.Calculation = xlCalculationManual

 Path = "PathToFolder" & "\"
 Filename = Dir(Path & "*.xl??")
 Set wsO = ThisWorkbook.Sheets("Sheet1")

You might want to add Application.EnableEvents = False. Other than that, nothing to change here, this is about as fast as it's ever going to get.


Do While Len(Filename) > 0
     Set wbk = Workbooks.Open(Path & Filename, True, True)
     ws = wbk.Worksheets.Count
     For i = 1 To ws
     Application.ScreenUpdating = False
     Application.DisplayAlerts = False
     Application.Calculation = xlCalculationManual
     Set rRng = Range("b1:b20")

This is mostly fine, except why are you re-setting all the Application.Settings options to false? They haven't changed from 6 lines ago. Just cut them out.

An obvious way to speed things up is not to open every worksheet in every workbook in this folder, but I'm going to assume that they are all required.

Opening a workbook does take time. If you've got a lot of them to open, then this macro is going to take time to run no matter how much you optimise it.


     For Each rCell In rRng.Cells
         If rCell <> "" And rCell.Value <> "Not Tested" Then

         wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = rCell
         wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 1).Value = rCell.Offset(0, -1)
         wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 2).Value = Right(ActiveWorkbook.FullName, 15)
         End If
     Next rCell

By process of elimination, any performance problems not related to opening the workbooks will be found here.

Fortunately, there are many things to be improved.


My personal #1 rule of fast spreadsheet manipulations:

Thou shalt not directly manipulate data in worksheets

By this I mean, doing anything in a worksheet has huge computational overhead. In the VBA object heirarchy, worksheets are only 2 steps removed from the application object itself. There are layers upon layers of abstractions, events, handlers, objects (not to mention several Billion range objects) buried in a worksheet object, and any time you do something in it, it will trigger a cascade of operations to make sure that nothing in your worksheet gets messed up.

For this reason, you should interact with worksheets as infrequently as possible. If there is data in your worksheet that you need to analyse: access the worksheet once to read the data into an Array, then do all your computations on the Array, then access the worksheet once to read the data back (if applicable).

Your sub then goes like this:

Sub AbesLoop()

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual

    Dim targetBook As Workbook
    Dim targetSheet As Worksheet

    Dim sheetCount As Long
    Dim targetFilename As String

    Dim outputSheet As Worksheet
    Set outputSheet = ThisWorkbook.Sheets("Sheet1") '/ Get this out of the way until we need it later

    Dim sheetRange As Range
    '/ Note the *descriptive*, *unambiguous* names.

    '/================================================================================================================================================
    '/================================================================================================================================================
    '/ Create the main array object, define columns, insert headers.

    Dim testOutputData As Variant
    testOutputData = Array()

    Dim testOutputRowIndex As Long
    testOutputRowIndex = 1
    ReDim testOutputData(1 To 3, 1 To testOutputRowIndex) '/ Defined it in a transposed state (column, row) because when extending arrays, if you want to preserve the data, you can only extend the final dimension.

    Const CELL_VALUE_COLUMN As Long = 1
    Const ADJACENT_CELL_VALUE_COLUMN As Long = 2 '/ It would really help when naming to know what this data actually is that you need to copy.
    Const WORKBOOK_NAME_COLUMN As Long = 3

    testOutputData(CELL_VALUE_COLUMN, testOutputRowIndex) = "Cell Value"
    testOutputData(ADJACENT_CELL_VALUE_COLUMN, testOutputRowIndex) = "Cell Value in adjacent (to left) column"
    testOutputData(WORKBOOK_NAME_COLUMN, testOutputRowIndex) = "Workbook Name"

    '/================================================================================================================================================
    '/================================================================================================================================================

    Dim sheetData As Variant
    sheetData = Array()

    Dim i As Long, j As Long
    Dim cellValue As Variant, adjacentCellValue As Variant

    targetFilename = Dir(FOLDER_PATH & "*.xl??")

    Do While Len(targetFilename) > 0
        Set targetBook = Workbooks.Open(FOLDER_PATH & targetFilename, True, True)
        sheetCount = targetBook.Worksheets.Count

        For i = 1 To sheetCount
            Set targetSheet = targetBook.Sheets(i)

            Set sheetRange = targetSheet.Range("a1:b20") '/ include the adjacent column in our data
            sheetData = sheetRange

            For j = 1 To 20
                cellValue = sheetData(j, 2) '/ column "a" is in 1, so "b" is 2
                If cellValue <> "" And cellValue <> 0 And cellValue <> Null And cellValue Is Not Nothing And cellValue <> "Not Tested" Then '/ Check for other versions of [No Data]

                    adjacentCellValue = sheetData(j, 1)

                    testOutputRowIndex = testOutputRowIndex + 1
                    ReDim Preserve testOutputData(1 To 3, 1 To testOutputRowIndex) '/ add an extra row to the end

                    testOutputData(CELL_VALUE_COLUMN, testOutputRowIndex) = cellValue
                    testOutputData(ADJACENT_CELL_VALUE_COLUMN, testOutputRowIndex) = adjacentCellValue
                    testOutputData(WORKBOOK_NAME_COLUMN, testOutputRowIndex) = targetBook.Name

                End If
            Next j
        Next i

        targetBook.Close False
        targetFilename = Dir
    Loop

    '/ --> [Transpose data array back to (row, column) form]. You can find a function on the internet or write your own.

    '/ print final data array back to sheet
    Set sheetRange = outputSheet.Range(Cells(1, 1), Cells(testOutputRowIndex, 3))
    sheetRange = testOutputData

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic

End Sub
\$\endgroup\$
  • \$\begingroup\$ Original OP here. I didnt know I could get all this information without opening the workbooks. I am still new at this. What is the generic syntax to be able to do that? I didnt think to load the copy'd information into an array, so that is actually a really good idea. \$\endgroup\$ – Doug Coats Feb 29 '16 at 17:06
  • \$\begingroup\$ If you want to read the data without actually opening the workbook? That's a good question. I'm not very familiar with doing that myself. I recommend googling around and looking through SO. \$\endgroup\$ – Kaz Feb 29 '16 at 17:40
  • \$\begingroup\$ You connect to it via ADODB @DougCoats. \$\endgroup\$ – RubberDuck Mar 1 '16 at 11:34
  • \$\begingroup\$ @DougCoats you can use something like this if you always use the same sheet name and cell range. \$\endgroup\$ – Raystafarian Mar 2 '16 at 12:48

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.