Comment accélérer une macro Excel VB

Question

J'essaie d'accélérer ma macro Excel VB. J'ai essayé les 5 alternatives ci-dessous. Mais je me demande si je pourrais raccourcir l'exécution plus loin. J'ai trouvé 2 alternatives dans les blogs utilisateurs que je n'ai pas réussi à utiliser. Une alternative est également trouvée dans un blog utilisateur mais ne comprend pas.

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 

Answer 1

Au lieu d'utiliser UsedRange, trouver la Last Row réelle et Last Column et utiliser cette gamme. UsedRange peut ne pas être la plage que vous pensez que c'est :). Vous voudrez peut-être voir THIS pour une explication.

Voir cet exemple (NON TESTÉ)

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