加速这个VBA了吗？

有没有办法加快这个代码？ 我需要它删除和写入相同的内容到单元格强制其他VBA代码运行在另一列。 这是什么，只是超级该死的慢。 而且这张纸上有时候有2000个条目/行。 它每个单元大约3秒钟，它几乎使我的CPU超出了大声笑。 （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 

Target.Value指的是第一段代码中的E列。 目前，我有第一块连接到一个button，但它是减速的方式。 而目标机器却不如我的那么强大。

Answer 1

使用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 

Answer 2

尝试这个

 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 

Answer 3

尝试使用声明。 并看看优化VBAmacros

 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 With ThisWorkbook.Sheets("Sales Entry") For Each cell In .Range("E2:E10") If Len(cell) > 0 Then Dim old As String old = cell.Value .Cells(4, r) = "" .Cells(4, r) = old r = r + 1 End If Next cell End With Cleanup: Application.ScreenUpdating = True ' etc.. ThisWorkbook.Sheets("Sales Entry").Protect "password!", AllowSorting:=True, AllowFiltering:=True End Sub