Question

我代表其他人发帖。希望我在这个过程中学到一些东西。

我的一个团队成员正在研究一个excel宏，它遍历包含超过14,000行的电子表格中的行。对于每个循环，它会将相关数据移动到工作簿中的新选项卡中。循环成功完成，除非我们使用LastRow变量，或者如果我们告诉它超过400-4500行，那么它会崩溃或挂起而没有任何有用的错误信息。该行为在不同的计算机上不会更改。我们使用Excel 2016来运行宏。我想与你分享代码，看看是否有什么东西导致它挂起（但为什么它可以正常工作多达4000行，然后退出？我怀疑内存问题是原因......）

如果在其他地方得到解答，我很抱歉，我没有足够的经验来确认某些建议是否适用于此特定代码。

以下是代码：

Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
    Dim sht As Worksheet

     If wb Is Nothing Then Set wb = ThisWorkbook
     On Error Resume Next
     Set sht = wb.Sheets(shtName)
     On Error GoTo 0
     SheetExists = Not sht Is Nothing
 End Function
Sub SortProductionIntoWorkcenters()

Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer

LastRow = Worksheets("TL Production").Cells.SpecialCells(Type:=XlCellType.xlCellTypeLastCell).Row
FirstRow = 3
Dim rng As Range, cel As Range
'The next line that says Cells(LastRow, 4)) is where I can change how may iterations the loop will process
Set rng = Worksheets("TL Production").Range(Cells(FirstRow, 4), Cells(LastRow, 4))
Dim SheetName As String
Dim r As Integer
r = 2

For Each cel In rng
    Worksheets("TL Production").Select
    If Cells(cel.Row, cel.Column) = "" Then
        Cells(cel.Row, cel.Column) = "EMPTY"
    End If

    SheetName = Worksheets("TL Production").Cells(cel.Row, 4).Value
    SheetName = Replace(SheetName, "/", " ")
    If Not SheetExists(SheetName) Then
        Worksheets.Add.Name = SheetName
    End If
    Worksheets("TL Production").Rows(cel.Row).Cut

    Do While r > 0

        If IsEmpty(Worksheets(SheetName).Cells(r, 1)) Then
            Worksheets(SheetName).Rows(r).Insert shift:=xlDown
            r = 2
            Exit Do
        End If
        r = r + 1
    Loop
Next cel
SecondsElapsed = Round(Timer - StartTime, 2)
  MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
'MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
 ' MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation

End Sub

Answer 1

不是答案，但您可以从简化代码中获益。例如：

For Each cel In rng
    Worksheets("TL Production").Select
    If cel = "" Then
        cel = "EMPTY"
    End If

    SheetName = cel

等...

Answer 2

虽然我不完全确定代码中的真正问题是什么（很可能与内存有关），但我看到了一些可以改善代码及其性能的东西。请参阅帖子底部，了解我的代码修订版提案。

For Each cel In rng
    Worksheets("TL Production").Select
    If Cells(cel.Row, cel.Column) = "" Then
        Cells(cel.Row, cel.Column) = "EMPTY"
    End If

每个循环执行.Select会大大减慢您的代码速度，因为每个.rows(r).Insert似乎都会更改为另一个工作表。因此，您的代码强制Excel不断切换工作表。重绘屏幕比执行计算或从工作表中读取某些值慢几个数量级。完全关闭屏幕更新可以进一步减轻这种情况：

Application.ScreenUpdating = False
ws.Select
For Each cel In rng.Cells
    ...
Next cel
Application.ScreenUpdating = True

如@PatrickHonorez所述，Cells(cel.Row, cel.Column)有点过头了。这是一种更复杂的引用cel方式 - 所以为什么不直接使用它？ :)由于没有完全引用，它也有不一定返回正确单元格的缺陷。（Cells实际上意味着ActiveWorkbook.ActiveSheet.Cells，因此如果您的工作簿/工作表因任何原因而发生变化，您的脚本会突然遇到麻烦。）

If cel.Value = "" Then
    cel.Value = "EMPTY"
End If

正如@dwirony的评论中所提到的，Do循环中的While r > 0条件并没有真正做任何事情。您的代码中没有允许r < 2的路径。此外，构造此循环的方式是宏执行缓慢的主要原因。（原始纸张中的数千行意味着我们同样经常进入这个特定的循环，并且由于目标纸张的增长，每次都必须计算得更高一些。）
我认为这是一个使用字典来存储你插入的最后一行数的好地方：

Do While r > 0
    DoEvents
    If IsEmpty(Worksheets(SheetName).Cells(r, 1)) Then
        Worksheets(SheetName).Rows(r).Insert shift:=xlDown
        dict(SheetName) = r
        Exit Do
    End If
    r = r + 1
Loop

通常：

在任何模块的顶部使用Option Explicit。它会让你的生活更轻松。（因此编译器会强制您声明您使用的每个变量。这使您的代码更简洁并消除了潜在的拼写错误以及其他好处。）您还可以将其作为VBA IDE选项中的标准。
如果您的宏修改的工作表包含公式，您可以使用Application.Calculation = xlCalculationManual停用自动重新计算（如果尚未设置为手动） - 这在某些情况下会进一步缩短执行时间。如果您想在之后将其设置为自动，请使用Application.Calculation = xlCalculationAutomatic。
为您不完全信任的每个Do循环添加一行DoEvents。如果结果是（几乎）无限循环，这将允许您停止/暂停宏。

我的修订版本，我测试了大约6000行，分发给3个不同的工作表。完成需要大约2分钟。虽然拥有更多数据的行可能比我的快速模型花费的时间更长。

Sub SortProductionIntoWorkcenters()

Dim StartTime As Double
Dim SecondsElapsed As Double
Dim LastRow As Long, FirstRow As Long
Dim Ws As Worksheet
Dim Dict As Scripting.Dictionary
StartTime = Timer

Set Dict = New Scripting.Dictionary
Set Ws = Worksheets("TL Production")    ' Set the reference to the starting sheet once and then use that
LastRow = Ws.Cells.SpecialCells(Type:=XlCellType.xlCellTypeLastCell).Row
FirstRow = 3
Dim rng As Range, cel As Range
'The next line that says Cells(LastRow, 4)) is where I can change how may iterations the loop will process
Set rng = Ws.Range(Cells(FirstRow, 4), Cells(LastRow, 4))
Dim SheetName As String
Dim r As Long    ' Use Long datatype here to prevent integer overflow
r = 2

Application.ScreenUpdating = False
For Each cel In rng.Cells   ' make explicit that we are iterating over all cells in range

    If cel.Value = "" Then
        cel.Value = "EMPTY"
    End If

    SheetName = Ws.Cells(cel.Row, 4).Value
    SheetName = Replace(SheetName, "/", " ")
    If Not SheetExists(SheetName) Then
        Worksheets.Add.Name = SheetName
    End If
    Ws.Rows(cel.Row).Cut

    If Dict.Exists(SheetName) Then r = Dict(SheetName)
    Do
        DoEvents
        If IsEmpty(Worksheets(SheetName).Cells(r, 1)) Then
            Worksheets(SheetName).Rows(r).Insert shift:=xlDown
            Dict(SheetName) = r + 1     ' Add one, as the row r is not empty by defition
            Exit Do
        End If
        r = r + 1
    Loop
Next cel
Application.ScreenUpdating = True
SecondsElapsed = Round(Timer - StartTime, 2)
  MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
'MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
 ' MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation

End Sub

大约4000次迭代后，VBA宏停止/挂起Excel

2 个答案: