Question

有没有办法加速这段代码？我需要它来删除并向单元格写入相同的内容，以强制其他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列。目前我将第一件连接到一个按钮，但它的速度有所减缓。而目标机器并不像我的那么强大。

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

尝试使用with statement。并查看Optimizing VBA macro

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

加速这个VBA？

3 个答案: