VBA 宏执行时间过长答案

【问题标题】：VBA macro takes too long to executeVBA 宏执行时间过长
【发布时间】：2014-09-28 04:44:12
【问题描述】：

这个非常简单的宏只需运行 55 次迭代就需要 93 秒。我也尝试将其作为 for next 循环，结果相同。

Dim thedate As Date
Dim current_cell As Long
Dim f As Single
f = Timer()

current_cell = Range("e65000").End(xlUp).Row

thedate = Range("e" & current_cell).Value
Dim i As Integer
Application.ScreenUpdating = False

Do Until Range("f" & current_cell).Value = ""
i = i + 1
If i = 900 Then
End
End If

    If Range("g" & current_cell).Value <> "x" Then
    Cells(current_cell, "e").Value = thedate
    Else
    thedate = thedate + 1
    Cells(current_cell, "e").Value = thedate
    End If
current_cell = current_cell + 1

Loop

Application.ScreenUpdating = True
MsgBox "ET: " & Format(Timer - f, "0.000") & "s"

第一次更新

好的，我查看了另一个页面，他们建议使用 with 功能。我这样做了，我仍然需要 28 秒才能循环通过 15 个单元格。

Dim thedate As Date
Dim current_cell As Long
Dim f As Single
f = Timer()


current_cell = Range("e65000").End(xlUp).Row

Dim stop_working As Long
stop_working = Range("f65000").End(xlUp).Row - 1

thedate = Range("e" & current_cell).Value
Dim i As Integer
Application.ScreenUpdating = False

With Sheets("time")

For k = current_cell To stop_working
i = i + 1
If i = 900 Then
End
End If

    If .Range("g" & current_cell).Value <> "x" Then
    .Cells(current_cell, "e").Value = thedate
    Else
    thedate = thedate + 1
    .Cells(current_cell, "e").Value = thedate
    End If
    current_cell = current_cell + 1

Next

End With

Application.ScreenUpdating = True
MsgBox "ET: " & Format(Timer - f, "0.000") & "s"

第三次更新

好的，我做了一些研究，我了解到您不应该循环范围，并且应该将范围放入数组中。我不太明白这一点，但我确实尝试将单元格放入一个数组并使用每个功能。看起来我仍然在循环范围，因为每当进入函数时，它仍然明显需要很长时间才能越过代码的 rng 部分。我的第二个问题是没有任何值在屏幕上发布。我的第三个问题是我的日期类型不匹配。我的第四个问题是我不明白 value 和 value2 之间的区别。

Sub dates()


Dim thedate
Dim current_cell As Long
Dim f As Single
f = Timer()
Dim rng As Range, rng2 As Range


current_cell = Range("e65000").End(xlUp).Row


Dim done As Long
done = Range("f65000").End(xlUp).Row - 1


Set rng = Range("g" & current_cell, "g" & done)
Set rng2 = Range("e" & current_cell, "e" & done)


thedate = Format(thedate, Date)
thedate = rng2.Value
'thedate = rng2.Value
Dim i As Integer
i = 7
'Application.ScreenUpdating = False


'With Sheets("time")


For Each cell In rng






    If cell.Value <> "x" Then
    rng2.Value = thedate
    Else
    thedate = thedate + 1
    rng2.Value = thedate
    End If



Next


'End With


'Application.ScreenUpdating = True
MsgBox "ET: " & Format(Timer - f, "0.000") & "s"

第四次更新

我有一个有效的新代码，但运行 50 次迭代仍需要 78 秒。不明白问题出在哪里。

Dim iRow As Long, erow As Long
erow = Cells(Rows.Count, "e").End(xlUp).Row
Dim thedate As Date
Dim f As Single
f = Timer()

    For iRow = erow To 35856
        If Cells(iRow, "G") = "x" Then

            Cells(iRow, "E").Value = Cells(iRow - 1, "E").Value + 1
        Else
            Cells(iRow, "E").Value = Cells(iRow - 1, "E").Value
        End If

    Next iRow

    MsgBox "ET: " & Format(Timer - f, "0.000") & "s"
End Sub

【问题讨论】：

您认为这似乎严重依赖工作表数据吗？
How to reduce runtime for code using ranges and string comparisons 的可能重复项
为什么要依赖工作表数据？我所做的只是确定 g 列单元格中是否有 x？
@user147178 请阅读建议的副本。这个问题的答案就是你的答案。
查看我对 OP 所做的编辑

标签： excel vba

【解决方案1】：

问题解决了。我需要将计算更改为手动并禁用触发事件。

Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    For iRow = 3 To Cells(Rows.Count, "G").End(xlUp).Row
        If Cells(iRow, "G") = "x" Then
            Cells(iRow, "E").Value = Cells(iRow - 1, "E").Value + 1
        Else
            Cells(iRow, "E").Value = Cells(iRow - 1, "E").Value
        End If
    Next iRow


    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

【讨论】：