Make the VBA code go faster

问题

How can i make my code go faster?

It's go real slow when the Vlookup is active and i don't know how to make it go fast.

It takes more than 2 minute and it's the same as doing manually.

Sub 


    Columns("I:I").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "KEY"
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "CHECK"
    Range("J2").Select
    ActiveCell.FormulaR1C1 = "=RC[7]&RC[12]&RC[16]"
    Range("J2").Select
  Selection.AutoFill Destination:=Range("j2:j" & cells(Rows.Count, "a").End(xlUp).Row)
       Sheets("CSI Plans Report").Select
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove


Application.Calculation = xlManual

    Sheets("CSI Plan ww").Select
    Range("J1:N1").Select
    Selection.Copy
    Sheets("CSI Plans Report").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.AutoFilter
    Selection.AutoFilter
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "=RC[7]&RC[12]&RC[16]"
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],'CSI Plan ww'!C[8]:C[12],2,0)"
    Range("C2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-2],'CSI Plan ww'!C[7]:C[11],3,0)"
    Range("D2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-3],'CSI Plan ww'!C[6]:C[10],4,0)"
    Range("E2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-4],'CSI Plan ww'!C[5]:C[9],5,0)"

    Range("A2").Select
    Selection.AutoFill Destination:=Range("A2:A" & cells(Rows.Count, "f").End(xlUp).Row)
     Range("B2").Select
    Selection.AutoFill Destination:=Range("b2:b" & cells(Rows.Count, "f").End(xlUp).Row)
     Range("C2").Select
    Selection.AutoFill Destination:=Range("c2:c" & cells(Rows.Count, "f").End(xlUp).Row)
     Range("D2").Select
     Selection.AutoFill Destination:=Range("d2:d" & cells(Rows.Count, "f").End(xlUp).Row)
     Range("E2").Select
    Selection.AutoFill Destination:=Range("e2:e" & cells(Rows.Count, "f").End(xlUp).Row)


Application.Calculation = xlAutomatic
    Range("A:E").Select
    Range("A:E").Copy
    Range("A:E").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False


    Sheets("CSI Plan ww").Select

    Range("I2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[1],'CSI Plans Report'!C[-8]:C[-3],6,0)"
    Range("I2").Select
     Selection.AutoFill Destination:=Range("i2:i" & cells(Rows.Count, "a").End(xlUp).Row)

    Columns("I:J").Copy
    Columns("I:J").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
End Sub

回答1:

If you turn off calculation you will save significant periods of time that would otherwise be devoted to calculating formulas that are only oin to be recalculated later.
If you put your formulas into all the rows at once, you do not have to have the calculation on; if you put them into a single cell and fill down you need to run a calculation cycle.
Anytime you can do multiple things at once is better than doing things repeatedly.
Everyone will tell you to read this. It is good advice.

Here's is my contribution to the rewrite process.

Option Explicit

Sub sonic()
    Dim lr As Long

    'uncomment the next line when you have completed debugging
    'appTGGL bTGGL:=False 'see appTGGL helper sub below for details on suspending the enviroment

    With Worksheets("CSI Plan ww")   '<~~you should know what worksheet you are on!!
        'don't insert a sinle column twice - insert 2 columns
        .Columns("I:J").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        'never do something twice when you do two things at once
        .Range("I1:J1") = Array("CHECK", "KEY")
        'write all of the formulas at once
        .Range(.Cells(2, "J"), .Cells(Rows.Count, "A").End(xlUp).Offset(0, 9)). _
            FormulaR1C1 = "=RC17&RC22&RC26"
    End With

    With Worksheets("CSI Plans Report")
        'again - all at once
        .Columns("A:E").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        'no need to select to make a copy
        Worksheets("CSI Plan ww").Range("J1:N1").Copy _
            Destination:=.Range("A1")
        'collect the last row so it doesn't have to be repeatedly looked up
        lr = .Cells(Rows.Count, "F").End(xlUp).Row
        'each column's formulas all at once
        .Range("A2:A" & lr).FormulaR1C1 = "=RC8&RC13&RC17"
        .Range("B2:B" & lr).FormulaR1C1 = "=VLOOKUP(RC1,'CSI Plan ww'!C10:C14, 2, 0)"
        .Range("C2:C" & lr).FormulaR1C1 = "=VLOOKUP(RC1,'CSI Plan ww'!C10:C14, 3, 0)"
        .Range("D2:D" & lr).FormulaR1C1 = "=VLOOKUP(RC1,'CSI Plan ww'!C10:C14, 4, 0)"
        .Range("E2:E" & lr).FormulaR1C1 = "=VLOOKUP(RC1,'CSI Plan ww'!C10:C14, 5, 0)"
        .Range("A2:E" & lr) = .Range("A2:E" & lr).Value2  'use .Value if any of these are dates
    End With


    With Worksheets("CSI Plan ww")
        .Range(.Cells(2, "I"), .Cells(Rows.Count, "A").End(xlUp).Offset(0, 8)). _
            FormulaR1C1 = "=VLOOKUP(RC10,'CSI Plans Report'!C1:C6, 6, 0)"
        'collect the last row so it doesn't have to be repeatedly looked up
        lr = .Cells(Rows.Count, "J").End(xlUp).Row
        'revert formulas to values
        .Range("I2:J" & lr) = .Range("I2:J" & lr).Value2  'use .Value if any of these are dates
    End With

    appTGGL 'turn everything back on

End Sub

Public Sub appTGGL(Optional bTGGL As Boolean = True)
    With Application
        .ScreenUpdating = bTGGL
        .EnableEvents = bTGGL
        .DisplayAlerts = bTGGL
        .Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
        .CutCopyMode = False
        .StatusBar = vbNullString
    End With
    Debug.Print Timer
End Sub

回答2:

This:

Range("A:E").Select
Range("A:E").Copy
Range("A:E").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

can be written as just:

Range("A:E").Value = Range("A:E").Value

回答3:

to achieve best performance in excel VBA try to not use Select.

instead of

Range("A2").Select
    Selection.AutoFill Destination:=Range("A2:A" & cells(Rows.Count, "f").End(xlUp).Row)

better use this

Range("A2").AutoFill Destination:=Range("A2:A" & cells(Rows.Count, "f").End(xlUp).Row)

And best what you can do is to specify sheet too (but it has nothing to do with performance, its just good practice)

Sheets("someSheetName").Range("A2").AutoFill Destination:=Range("A2:A" & cells(Rows.Count, "f").End(xlUp).Row)

And i strongly recomend to use on begining of your sub

application.screenUpdating = false

and this on end of your sub

application.screenUpdating = true

So your excel wont show any change imediately, but at once at the end of the code. (you can read more about screenUpdating almost everywhere on web)

I think this can make you some performance boost.

回答4:

What I usually do, when writing macros is the following:

Public Sub MyMainMacro

   Call OnStart
    'Here comes the code
   Call OnEnd

End Sub

Public Sub OnStart()

    Application.ScreenUpdating = False
    Application.Calculation = xlAutomatic
    Application.EnableEvents = False

End Sub

Public Sub OnEnd()

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.StatusBar = False

End Sub

来源：https://stackoverflow.com/questions/36467663/make-the-vba-code-go-faster

标签

excel

vba

excel-vba

vlookup