提高VBA批处理脚本的性能？

Question

我正在使用脚本打开一堆Excel文件，将两个或多个工作表复制到一个新文件中并保存这个新文件。它肯定比手工操作要好，但我认为它可能会更快。

这是我的剧本：

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

有什么办法能让它更快地工作吗？

-编辑-脚本每个文件大约需要3-6秒。这不算太多，但我觉得可能会快得多。或者这是我所期望的最快的VBA吗？

Answer 1

这里最大的瓶颈是Dim app As New Excel.Application。打开一个全新的excel实例是昂贵的，即使你只做了一次。相反，您可以获取Excel的现有实例(如果有)，如果没有，则仍然可以创建一个新的实例。剩下的代码非常简单。

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

另一件需要注意的事情是，您正在删除三个工作表，NewBook.Sheets(1).Delete，但这假定excel工作簿中已经打开了三个工作表。并不是每个人都是这样建立自己的excel的。您可能最终会删除刚才复制的数据。

Answer 2

你的床单上有什么“花哨”吗？(即特殊格式、枢轴、公式？)如果没有--或者即使你做了，但是有了更多的工作--你应该能够将值复制到Sheet1并重命名，而不是移动整个工作表。

修改Loop以处理纯数据(不格式化)示例：

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