循环通过 10,000 个单元格时如何使 VBA 代码运行得更快？

Question

Sub GMC()  
    strike = 100
    cap = 120
    part = 3.25
    KO = 60

    For i = 1 To 1000
        exp(i) = Worksheets("Speeder premium").Cells(i + 1, 32)
        If exp(i) >= cap Then
            cash = strike + (part * (cap - strike))
        ElseIf exp(i) >= strike And exp(i) < cap Then
            cash = strike + (part * (exp(i) - strike))
        ElseIf exp(i) < strike And exp(i) >= KO Then
            cash = strike
        ElseIf exp(i) < strike And exp(i) < KO Then
            cash = exp(i)
        End If
        
        Worksheets("Speeder premium").Cells(i + 1, 33) = cash
    Next i
End Sub

所以现在我将下面的代码重复 1000 次，但理想情况下我希望这样做 10,000 次。我尝试使用 10,000 进行此操作，但速度非常慢并且处理时间太长。如何让代码更快更高效？

Answer 1

使用数组

• 我鼓励您使用Option Explicit，这将强制您声明所有变量，这些变量将使代码更具可读性、意外行为（错误）更易于追踪……这需要更多的工作，但在从长远来看，它一定会得到回报。

快速修复

Sub GMC()
    ' Worksheet
    wsName = "Speeder premium"
    fRow = 2
    rCount = 10000
    sCol = 32
    dCol = 33
    ' Data
    Strike = 100
    cap = 120
    part = 3.25
    KO = 60
    ' Define workbook.
    Set wb = ThisWorkbook
    ' Define Source Range.
    Set rng = wb.Worksheets(wsName).Cells(fRow, sCol).Resize(rCount)
    ' Write values from Source Range to Source Array.
    Source = rng.Value
    ' Define Destination Array.
    ReDim Dest(1 To rCount, 1 To 1)
    ' Loop through rows of Source Array, do the calculation, 
    ' and write the results to Destination Array.
    For i = 1 To rCount
        Curr = Source(i, 1)
        If Curr >= cap Then
            cash = Strike + (part * (cap - Strike))
        ElseIf Curr >= Strike And Curr < cap Then
            cash = Strike + (part * (Curr - Strike))
        ElseIf Curr < Strike And Curr >= KO Then
            cash = Strike
        ElseIf Curr < Strike And Curr < KO Then
            cash = Curr
        End If
        Dest(i, 1) = cash
    Next i
    ' Write values from Destination Array to Destination Range.
    rng.Offset(, dCol - sCol).Value = Dest

End Sub

选项显式版本

Option Explicit

Sub GMC2()
    ' Worksheet
    Const wsName As String = "Speeder premium"
    Const fRow  As Long = 2
    Const rCount As Long = 10000
    Const sCol As Long = 32
    Const dCol As Long = 33
    ' Source
    Const Strike As Long = 100
    Const Cap As Long = 120
    Const Part As Double = 3.25
    Const KO As Long = 60
    ' Define Source Range.
    Dim wb As Workbook
    Set wb = ThisWorkbook
    Dim rng As Range
    Set rng = wb.Worksheets(wsName).Cells(fRow, sCol).Resize(rCount)
    ' Write values from Source Range to Source Array.
    Dim Source As Variant
    Source = rng.Value
    ' Define Target Array.
    Dim Dest As Variant
    ReDim Dest(1 To rCount, 1 To 1)
    ' Loop through rows of Source Array, do the calculation, and write
    ' the results to Destination Array.
    Dim Curr As Variant
    Dim i As Long
    Dim Cash As Double
    For i = 1 To rCount
        Curr = Source(i, 1)
        If Curr >= Cap Then
            Cash = Strike + (Part * (Cap - Strike))
        ElseIf Curr >= Strike And Curr < Cap Then
            Cash = Strike + (Part * (Curr - Strike))
        ElseIf Curr < Strike And Curr >= KO Then
            Cash = Strike
        ElseIf Curr < Strike And Curr < KO Then
            Cash = Curr
        End If
        Dest(i, 1) = Cash
    Next i
    ' Write values from Destination Array to Destination Range.
    rng.Offset(, dCol - sCol).Value = Dest

End Sub

以变量声明开头的选项显式版本

Sub GMC3()
    ' Worksheet
    Const wsName As String = "Speeder premium"
    Const fRow  As Long = 2
    Const rCount As Long = 10000
    Const sCol As Long = 32
    Const dCol As Long = 33
    ' Source
    Const Strike As Long = 100
    Const Cap As Long = 120
    Const Part As Double = 3.25
    Const KO As Long = 60
    ' Variables
    Dim wb As Workbook
    Dim rng As Range
    Dim Source As Variant
    Dim Dest As Variant
    Dim Curr As Variant
    Dim i As Long
    Dim Cash As Double
    ' Define Source Range.
    Set wb = ThisWorkbook
    Set rng = wb.Worksheets(wsName).Cells(fRow, sCol).Resize(rCount)
    ' Write values from Source Range to Source Array.
    Source = rng.Value
    ' Define Target Array.
    ReDim Dest(1 To rCount, 1 To 1)
    ' Loop through rows of Source Array, do the calculation, and write
    ' the results to Destination Array.
    For i = 1 To rCount
        Curr = Source(i, 1)
        If Curr >= Cap Then
            Cash = Strike + (Part * (Cap - Strike))
        ElseIf Curr >= Strike And Curr < Cap Then
            Cash = Strike + (Part * (Curr - Strike))
        ElseIf Curr < Strike And Curr >= KO Then
            Cash = Strike
        ElseIf Curr < Strike And Curr < KO Then
            Cash = Curr
        End If
        Dest(i, 1) = Cash
    Next i
    ' Write values from Destination Array to Destination Range.
    rng.Offset(, dCol - sCol).Value = Dest

End Sub

编辑

• 这里有一个测试可以解释为什么这个代码更快。在新工作簿中使用它。

测试

Option Explicit

Sub SpeedTest()
    
    Const Reps As Long = 1000000
    Dim Data As Variant
    ReDim Data(1 To Reps, 1 To 1)
    Dim Data2 As Variant
    ReDim Data2(1 To Reps, 1 To 1)
    Dim t As Double
  
    t = Timer
    With Sheet1.Cells(1, 1).Resize(Reps)
        .Value = Empty
        '.Value = 20000
        '.Value = "This is a test."
        ' This one might take a while (15-20s)(uncomment all four lines):
'        .Offset(, 1).Formula = "=RANDBETWEEN(1,5000)"
'        .Offset(, 1).Value = .Offset(, 1).Value
'        .Formula = "=IF(B1>2500,B1,A1)"
'        .Value = .Value
    End With
    t = Timer - t
    Debug.Print "It took " & t _
        & " seconds to write the data to the worksheet."
    
    t = Timer
    Dim n As Long
    For n = 1 To Reps
        Data(n, 1) = Sheet1.Cells(n, 1).Value
    Next n
    t = Timer - t
    Debug.Print "It took " & t _
        & " seconds to access the worksheet " & Reps _
        & " times to read one cell value."
    Erase Data
    
    t = Timer
    Data2 = Sheet1.Cells(1, 1).Resize(Reps).Value
    t = Timer - t
    Debug.Print "It took " & t _
        & " seconds to access the worksheet once to read " & Reps _
        & " values."
    Erase Data2

End Sub