Improving performance of VBA batch scripts?

Question

I am using a script to open a bunch of Excel files, copying two or more sheets into a new file and saving this new file. It sure beats doing it manually, but I think it could be faster.

Here's my script:

Sub Flujo()
Const FilePath = "A path..."
Const Destination = "Another path..."
Dim app As New Excel.Application
app.Visible = False
app.ScreenUpdating = False
app.DisplayAlerts = False
Dim str As String
str = Dir(FilePath & "\*.xlsx")
Do Until str = ""
 Dim WrkBook As Workbook
 Set WrkBook = app.Workbooks.Open(Filename:=FilePath & "\" & str, UpdateLinks:=0)
 str = Dir()
 Dim NewBook As Workbook
 Set NewBook = app.Workbooks.Add
 WrkBook.Sheets("SheetName").Copy After:=NewBook.Sheets(3)
 WrkBook.Sheets("AnotherSheetName").Copy After:=NewBook.Sheets(3)
 NewBook.Sheets(1).Delete
 NewBook.Sheets(1).Delete
 NewBook.Sheets(1).Delete
 NewBook.SaveAs Filename:=Destination & "flujo_" & WrkBook.Name
 NewBook.Close False
 WrkBook.Close False
Loop
app.DisplayAlerts = True
app.Quit
Set app = Nothing
End Sub

Is there a way I could make it work faster?

-Edit- The script takes more or less 3 - 6 seconds per file. That's not too much but I feel it could be much faster. Or is this the fastest I can expect to get with VBA?

• kurast: Is WrkBook large? Which part of the code you feel is slower? The open, the moving of the sheets, the saving?
• user3680808: It's not very large, and I can't know which step takes the longest because the script does everything automatically.
• Tim Williams: How long does it take, and how long would you like it to take? Opening the source workbook as readonly might be slightly faster. When you add the new workbook you can specify only one sheet [Workbooks.Add(xlWBATWorksheet)], so then you have fewer sheets to delete later. Otherwise there don't seem to be any clear ways to really speed this up unless you're opening/saving on a slow network and not a local drive.
• user3680808: Edited the original post.
• Andy G: Small changes would be to temporarily turn off calculation: Application.Calculation = xlCalculationManual, use the WorkSheets collection rather than Sheets. Also, if the workbooks are saved to a remote location, you might save them locally then, afterwards, copy them to the remote location.

Answer 1

Rather than copying sheet by sheet - plus deleting three excess sheets one by one, either

1. Delete the sheets you don't need then use SaveAs on the reduced file.
2. Copy both sheets you need to a new file in a single hit.

(Also, don't Dim variables inside a loop)

(2) below

Sub Flujo()
Const FilePath = "A path..."
Const Destination = "Another path..."
Dim xlApp As New Excel.Application
With xlApp
 .Visible = False
 .ScreenUpdating = False
 .DisplayAlerts = False
End With
Dim strDir As String
Dim WrkBook As Workbook
strDir = Dir(FilePath & "\*.xlsx")
Do While Len(strDir) > 0 
Set WrkBook = xlApp.Workbooks.Open(Filename:=FilePath & "\" & strDir, UpdateLinks:=0)
 WrkBook.Sheets(Array("SheetName", "AnotherSheetName")).Copy
 ActiveWorkbook.SaveAs Filename:=Destination & "flujo_" & WrkBook.Name
 ActiveWorkbook.Close False
 WrkBook.Close False
strDir = Dir 
Loop
xlApp.DisplayAlerts = True
xlApp.Quit
Set xlApp = Nothing
End Sub

• Mathieu Guindon: Dim variables inside a loop has no importance in VBA (it does in VB.NET though) - but I agree with the recommendation, for readability purposes. +1

Answer 2

The biggest bottle neck here is Dim app As New Excel.Application. Opening up a brand new excel instance is costly even if you do it once. Instead you can grab an existing instance of Excel (if there is one) if not then you can create a new one still. The rest of your code is pretty simple.

Function GetExcelApplication(Optional ByRef WasANewInstanceReturned As Boolean) As Excel.Application
 If ExcelInstanceCount > 0 Then
 Set GetExcelApplication = GetObject(, "Excel.Application")
 WasANewInstanceReturned = False
 Else
 Set GetExcelApplication = New Excel.Application
 WasANewInstanceReturned = True
 End If
End Function
Function ExcelInstanceCount() As Integer
 Dim objList As Object, objType As Object, strObj As String
 strObj = "Excel.exe"
 Set objType = GetObject("winmgmts:").ExecQuery("select * from win32_process where name='" & strObj & "'")
 ExcelInstanceCount = objType.Count
End Function

Another thing to be aware of is that you are deleting three sheets, NewBook.Sheets(1).Delete, but this assumes an excel workbook opens with three sheets in it already. Not everyone has their excel set up this way. you might end up deleting the data you just copied in.

• user3680808: The thing is I'm not opening a new Excel instance every time, if you take a look at the code, the instance is created at the beginning and then the loops goes through all the files using that same app.
• Brad: That was just the thing that stood out to me. But you could say what line is slowest, it would be helpful. How slow is 'slow'?

Answer 3

Do you have anything 'fancy' in your sheet? (i.e. special formatting, pivots, formulas?) If not -- or even if you do, but with more work -- you should be able to copy the values into Sheet1 and rename, rather than move the entire sheet.

Modifying your Loop to work with a pure data (no formatting) example:

Do Until str = ""
 Dim WrkBook As Workbook
 Set WrkBook = app.Workbooks.Open(Filename:=FilePath & "\" & str, UpdateLinks:=0)
 str = Dir()
 Dim NewBook As Workbook
 Set NewBook = app.Workbooks.Add
 NewBook.Sheets(1).Name = "SheetName"
 NewBook.Sheets(2).Name = "AnotherSheetName"
 NewBook.Sheets(3).Delete
 NewBook.Sheets("SheetName").Range("A1:D100").Value = WrkBook.Sheets("SheetName").Range("A1:D100").Value
 NewBook.Sheets("AnotherSheetName").Range("A1:D100").Value = WrkBook.Sheets("AnotherSheetName").Range("A1:D100").Value
 ' Use of a specific range if known is best, though you could use .Cells, but this is likely to be slower
 ' NewBook.Sheets("SheetName").Cells.Value = WrkBook.Sheets("SheetName").Cells.Value
 ' There are other methods around to identfy the usable range as well
 ' Dim lMaxRow As Long
 ' With WrkBook.Sheets("SheetName")
 ' lMaxRow .Range("D" & .Rows.CountLarge).End(xlUp).Row
 ' End With
 ' NewBook.Sheets("SheetName").Range("A1:D" & lMaxRow).Value = WrkBook.Sheets("SheetName").Range("A1:D" & lMaxRow).Value
 NewBook.SaveAs Filename:=Destination & "flujo_" & WrkBook.Name
 NewBook.Close False
 WrkBook.Close False
Loop