加快VBA的速度？

有没有办法加速这个代码？我需要它删除并将相同的内容写入单元格，以强制其他VBA代码在另一列上运行。这就是它所做的，只是超他妈的慢。这张表上有时有2000个条目/行。每个单元大约3秒，它几乎使我的CPU最大化了lol（i7 6850k@4.4ghz）

原因是，有时数据会从电子表格的旧版本复制到新版本，并且VBA更新列不会更新，除非我实际更改单元格的检查

Sub ForceUpdate()
    On Error GoTo Cleanup
    Application.ScreenUpdating = False ' etc..
    ThisWorkbook.Sheets("Sales Entry").Unprotect "password!"
    Dim cell As Range, r As Long
    r = 2
    For Each cell In ThisWorkbook.Sheets("Sales Entry").Range("E2:E10")
        If Len(cell) > 0 Then
            Dim old As String
            old = cell.Value
            ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = ""
            ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = old
            r = r + 1
        End If
    Next cell
Cleanup:
    Application.ScreenUpdating = True ' etc..
    ThisWorkbook.Sheets("Sales Entry").Protect "password!", _  
        AllowSorting:=True, AllowFiltering:=True
End Sub

另一个VBA部分中的代码为

If StrComp("pp voice", Target.Value, vbTextCompare) = 0 Then
    Target.Value = "PP Voice"
    Target.Offset(0, 8).Value = "N\A"
    Target.Offset(0, 8).Locked = True
    Target.Offset(0, 10).Value = "N\A"
    Target.Offset(0, 10).Locked = True
End If

Value是指第一段代码中的E列。目前，我有一个按钮连接到第一块，但它的方式缓慢。而且目标机器没有我的强大。

尝试使用with语句。 看一看

试试这个

Option Explicit

Sub ForceUpdate()


    On Error GoTo Cleanup
    Dim SalesEntrySheet As Worksheet
    Set SalesEntrySheet = ThisWorkbook.Sheets("Sales Entry")

    Application.ScreenUpdating = False ' etc..


    SalesEntrySheet.Unprotect "password!"

    Dim cell As Range, r As Long
    Dim ArrayPos As Long
    Dim SalesEntrySheetArray As Variant

    With SalesEntrySheet
        'Starting with row one into the array to ease up the referencing _
            so Array entry 2 will be for row 2
        SalesEntrySheetArray = .Range("E1:E" & .Cells(.Rows.Count, "E").End(xlUp).Row)

        'Clearing the used range in Col E
        'If you are using a WorkSheet_Change for the second part of your code then you should rather make this a loop
        .Range("E1:E" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value = ""

        'Putting the values back into the sheet
        For ArrayPos = 2 To UBound(SalesEntrySheetArray, 1)

            .Cells(ArrayPos, "E").Value = SalesEntrySheetArray(ArrayPos, 1)

        Next ArrayPos

    End With

    Cleanup:
    Application.ScreenUpdating = True ' etc..
    ThisWorkbook.Sheets("Sales Entry").Protect "password!", AllowSorting:=True, _
    AllowFiltering:=True

End Sub

---

使用application.enableevents=false和application.calculation=xlcalculationmanual。在退出之前重新打开它们。如果每个单元格需要3秒，则必须触发大事件或复杂的计算周期

变,

Dim cell As Range, r As Long
r = 2
For Each cell In ThisWorkbook.Sheets("Sales Entry").Range("E2:E10")
    If Len(cell) > 0 Then
    Dim old As String
    old = cell.Value
    ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = ""
    ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = old
    r = r + 1
    End If
Next cell

。。。对,

Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim cell As Range
With ThisWorkbook.Sheets("Sales Entry")
    For Each cell In .Range("E2:E10")
        If CBool(Len(cell.Value2)) Then
            cell = cell.Value2
        End If
    Next cell
End With

Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

---

你真正想做的是把这篇文章贴在他们关注的地方，让他们审查/优化正在运行的代码。可能会有帮助的是使用

数组

，它将从工作表中获取数据，然后您可以处理

数组

，然后将数据发送到新工作表。使用application.enableevent=false和application.calculation=xlcalculationmanual。在退出之前重新打开它们。如果每个单元格需要3秒，则必须触发大型事件或复杂的计算周期；您只是在

If

中迭代

r

，这意味着某些值可能会向上传递。我删除了它。我不得不注释掉顶部的启用事件，并修改了范围，使其与数据一起转到底部一行。工作，屏幕挂起，而它这样做，CPU并没有发疯，但。一旦Excel完成了它的任务，一切都正常了。不太理想，但按钮很少被按下就可以了。奇怪的是，在工作机器上运行这段代码（很确定是2013年），速度要快得多，几乎比我2016年运行的机器上的要快。你的工作机器上有64位操作系统上的64位Excel，但你的个人电脑上只有64位操作系统上的32位Excel吗？我敢肯定，在工作中都是32位Excel，在个人电脑上是64位Excel。虽然这非常快，但它所做的只是清除列。@BenLogan，我想先清除所有单元格，以便在循环中保存一行执行。是的，只是在清除之后没有将它们放回：）@BenLogan抱歉，我错过了数组的维度级别。现在试试看

Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim cell As Range
With ThisWorkbook.Sheets("Sales Entry")
    For Each cell In .Range("E2:E10")
        If CBool(Len(cell.Value2)) Then
            cell = cell.Value2
        End If
    Next cell
End With

Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True