Question

有一个程序可以清除某些细胞范围的内容。它工作正常，但很慢（7分钟）。如何加速这个计划？

Sub óäàëèòü()
    Dim book1 As Workbook
    Dim B As String
    Dim v As Long
    Dim e As Long

    B = "14"

    Set book1 = Workbooks.Open("E:\Super M\Ïðîåêò ñòàâêè\Ïîèñê ðåøåíèÿ\Óñîâ 7\Óñëîâèÿ äëÿ àíäåðäîãîâ\" + B + ".xlsm")

    For v = 1 To 14
        For e = 0 To 8
            book1.Worksheets("Ëèñò" & v).Cells(34, 26 + (e * 21)).Resize(128, 5).ClearContents
        Next e
    Next v

    book1.Save
    book1.Close

End Sub

Answer 1

提高性能的一种方法是禁用Excel计算和屏幕更新，如下所示，这样应用程序可以减少计算。

Sub óäàëèòü()
    Dim book1 As Workbook
    Dim B As String
    Dim v As Long
    Dim e As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    B = "14"

    Set book1 = Workbooks.Open("E:\Super M\Ïðîåêò ñòàâêè\Ïîèñê ðåøåíèÿ\Óñîâ 7\Óñëîâèÿ äëÿ àíäåðäîãîâ\" + B + ".xlsm")

    For v = 1 To 14
        For e = 0 To 8
            book1.Worksheets("Ëèñò" & v).Cells(34, 26 + (e * 21)).Resize(128, 5).ClearContents
        Next e
    Next v

    book1.Save
    book1.Close

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

End Sub

Answer 2

我看到你已经接受了答案。但是，我应该有兴趣知道下面编码的想法是否具有可比性。代码选择所有14张纸并在一次操作中删除所有这些纸张中的范围而不是126。

Sub Something()
    ' 29 Jan 2018

    Dim Book1 As Workbook
    Dim WsNames(1 To 14) As Variant
    Dim WsArr As Variant
    Dim Rng As Range
    Dim B As String
    Dim v As Long
    Dim e As Long

    B = "14"
    Set Book1 = Workbooks.Open("E:\Super M\?e??¨º¨° ?¨°¨¤a¨º¨¨\??¨¨?¨º e???¨ª¨¨?\¨®??a 7\¨®???a¨¨? ??? ¨¤¨ª??e????a\" + B + ".xlsm")

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    For v = 1 To 14                     ' match loops to declaration
        WsNames(v) = "Sheet" & v
    Next v
    For e = 0 To 8
        B = Cells(34, 26 + (e * 21)).Resize(128, 5).Address
        With Book1.Worksheets(WsNames(1))
            If Rng Is Nothing Then
                Set Rng = .Range(B)
            Else
                Set Rng = Application.Union(Rng, .Range(B))
            End If
        End With
    Next e

    Set WsArr = Worksheets(WsNames)
    WsArr.Select
    Rng.Select
    Selection.ClearContents

    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

    With Book1
        .Worksheets(WsNames(1)).Activate
        .Save
        .Close
    End With
End Sub

Answer 3

`Sub` óäàëèòü()
    Dim book1 As Workbook
    Dim B As String
    Dim v As Long
    Dim e As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    If Workbooks.Count Then
      ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False
    End If
    Application.DisplayStatusBar = False
    Application.DisplayAlerts = False
    B = "14"

      Set book1 = Workbooks.Open("E:\Super M\Ïðîåêò ñòàâêè\Ïîèñê ðåøåíèÿ\Óñîâ                                
      7\Óñëîâèÿ äëÿ àíäåðäîãîâ\" + B + ".xlsm")
      For v = 1 To 14
        For e = 0 To 8
            book1.Worksheets("Ëèñò" & v).Cells(34, 26 + (e * 21)).Resize(128,5).
    ClearContents        
        Next e
    Next v

    book1.Save
    book1.Close

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

     If Workbooks.Count Then
      ActiveWorkbook.ActiveSheet.DisplayPageBreaks = True

    End If
     Application.DisplayStatusBar = True
     Application.DisplayAlerts = True
     End Sub

我添加了一些技巧，并且也链接到了非常有用的文章（对我来说）
在Google中优化查找将是第一个链接

清除细胞内容

3 个答案: