CODEWITHSUNDEEP
excelaccelerationvba
Andre
Andre

Reputation: 1

How to accelerate an Excel VB Macro

I am trying to accelerate my Excel VB Macro. I have tried the 5 alternatives below. But I wonder if I could shorten the execution further. I found 2 alternatives in User Blogs which I could not get to work. One alternative is also found in a User Blog but do not understand.

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

Upvotes: 0

Views: 337

Answers (1)

Siddharth Rout
Siddharth Rout

Reputation: 149325

Instead of using UsedRange, find the actual Last Row and Last Column and use that range. UsedRange may not be the range that you think it is :). You may want to see THIS for an explanation.

See this example (UNTESTED)

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

Upvotes: 2

Related Questions