VBA 宏执行时间过长
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/26081705/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
VBA macro takes too long to execute
提问by user147178
This very simple macro is taking 93 seconds just run through 55 iterations. I also tried it as a for next loop, same result.
这个非常简单的宏只运行 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"
FIRST UPDATE
第一次更新
Ok, I looked at another page and they recommended using the with feature. I did that and it still took me 28 seconds to loop through 15 cells.
好的，我查看了另一个页面，他们建议使用 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"
THIRD UPDATE
第三次更新
Ok, I've done some research and I learned that you're not supposed to loop over ranges and that you're supposed to put the ranges in an array. I don't really understand this but I did try putting the cells into an array and using the for each feature. It still seems like I'm looping over ranges because whenever a step into the function it still noticeably takes a very long time to cross over the rng part of the code. My second problem is that none of the values are getting published on the screen. My third problem is that I'm getting a type mismatch with thedate. My fourth problem is that I don't understand the difference betwene value and value2.
好的，我做了一些研究，我了解到你不应该循环遍历范围，你应该把范围放在一个数组中。我不太明白这一点，但我确实尝试将单元格放入数组并使用 for 每个功能。看起来我仍然在循环范围内，因为每当进入函数时，它仍然需要很长时间才能跨越代码的 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"
4TH UPDATE
第四次更新
I have a new code that works but it still take 78 seconds to run through 50 iterations. Don't understand what the problem is.
我有一个有效的新代码，但运行 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
回答by user147178
Problem solved. I need to change calculation to manual and disable the firing of events.
问题解决了。我需要将计算更改为手动并禁用事件触发。
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
