如何加速 Excel VBA 宏

Posted 2023-02-22

【中文标题】如何加速 Excel VBA 宏

【英文标题】：How to accelerate an Excel VB Macro

【发布时间】：2017-05-28 14:59:53

【问题描述】：

我正在尝试加速我的 Excel VB 宏。 我已经尝试了以下 5 种选择。 但我想知道我是否可以进一步缩短执行时间。 我在用户博客中找到了 2 个我无法开始工作的替代方案。 在用户博客中也找到了一种替代方法，但不明白。

Sub AccelerateMacro()

'
' v1 052817 by eb+mb
' Macro to copy as fast as possible sheet from one workbook into another workbooks
' Declarations for variables are not shown to make code example more legible
' Macro is stored in and run from "DestinationWorkBook.xlsm"

StartTime = Timer

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Alternative = "First"

If Alternative = "First" Then
    Workbooks.Open Filename:="SourceWorkBook.xls"
    Cells.Select
    Selection.Copy
    Windows("DestinationWorkBook.xlsm").Activate
    Sheets("DestinationSheet").Select
    Range("A1").Select
    ActiveSheet.Paste
    Windows("SourceWorkBook.xls").Activate
    ActiveWorkbook.Close
End If

If Alternative = "Second" Then
    Workbooks.Open Filename:="SourceWorkBook.xls", ReadOnly:=True
    Cells.Select
    Selection.Copy
    Windows("DestinationWorkBook.xlsm").Activate
    Sheets("DestinationSheet").Select
    Range("A1").Select
    ActiveSheet.Paste
    Workbooks("SourceWorkBook.xls").Close SaveChanges:=False
End If

If Alternative = "Third" Then
' I could not get this alternative to work
    Workbooks.Open("SourceWorkBook.xls").Worksheets("SourceSheet").Copy
    Workbooks.Open("DestinationWorkBook.xlsm").Worksheets("DestinationSheet").Range("A1").PasteSpecial
End If

If Alternative = "Fourth" Then
' I could not get this alternative to work
    Workbooks.Open("DestinationWorkBook.xlsm").Worksheets("DestinationSheet").Range("A1") = Workbooks.Open("SourceWorkBook.xls").Worksheets("SourceSheet")
End If

If Alternative = "Fifth" Then
' I don't understand the code in this alternative
    Dim wbIn As Workbook
    Dim wbOut As Workbook
    Dim rSource As Range
    Dim rDest As Range
    Set wbOut = Application.Workbooks.Open("DestinationWorkBook.xlsm")
    Set wbIn = Application.Workbooks.Open("SourceWorkBook.xls")
    With wbIn.Sheets("SourceSheet").UsedRange
    wbOut.Sheets("DestinationSheet").Range("A1").Resize(.Rows.Count, .Columns.Count) = .Value
End With


SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation

End Sub

【问题讨论】：

你试过Alternative = "Fifth"吗？

【参考方案1】：

不使用UsedRange，而是找到实际的Last Row 和Last Column 并使用该范围。 UsedRange 可能不是您认为的范围:)。您可能想查看THIS 以获得解释。

查看此示例（未测试）

Sub Sample()
    Dim wbIn As Workbook, wbOut As Workbook
    Dim rSource As Range
    Dim lRow As Long, LCol As Long
    Dim LastCol As String

    Set wbOut = Workbooks.Open("DestinationWorkBook.xlsm")
    Set wbIn = Workbooks.Open("SourceWorkBook.xls")

    With wbIn.Sheets("SourceSheet")
        '~~> Find Last Row
        lRow = .Cells.Find(What:="*", _
                After:=.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row

        '~~> Find Last Column
        LCol = .Cells.Find(What:="*", _
                After:=.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Column

        '~~> Column Number to Column Name
        LastCol = Split(Cells(, LCol).Address, "$")(1)

        '~~> This is the range you want
        Set rSource = .Range("A1:" & LastCol & lRow)

        '~~> Get the values across
        wbOut.Sheets("DestinationSheet").Range("A1:" & LastCol & lRow).Value = _
        rSource.Value
    End With
End Sub