删除行缓慢的过程 - 如何做得更快？ [英] Slow process on deleting rows - How to make faster?

问题描述

我的工作簿中有几个宏。这是唯一一个似乎在2500行页上3-5分钟真的很慢的

目的是如果Row在日期dtFrom和dtUpTo之间然后删除整个

我添加了暂停和恢复计算，并略微提高了

任何人都有任何想法如何为了使这个更快？

  Sub DeleteRows 
'---暂停计算：
 Application.Calculation = xlManual 
'----- DELETE ROWS ----- 
 Dim dtFrom As Date 
 Dim dtUpto As Date 
 Dim y As Long 
 Dim vCont As Variant 
 dtFrom = Sheets（Control Panel）。Range（D5）。value 
 dtUpto = dtFrom + 6 
 Sheet1.Range（D1）。Value2 =扫描，请等待...
 With Sheets（Database）
对于y = Sheet5.Cells（Sheet5.Rows.Count，2）.End（xlUp）.Row + 1 To 2 Step -1 
 vCont = .Cells（y，1）.Value 
如果不是IsError（vCont）然后
如果vCont> ; = dtFrom And vCont <= dtUpto Then 
 .Rows（y）.EntireRow.Delete 
 End If 
 End If 
 Next 
 End with 
 '---恢复计算：
 Application.Calculation = xlAutomatic 
 End Sub 
  

解决方案

请尽量在最后的所有相关行中执行一个删除操作：

  Sub DeleteRows（）
'---暂停计算：
 Application.Calculation = xlManual 
'---- -  DELETE ROWS ----- 
 Dim dtFrom As Date 
 Dim dtUpto As Date 
 Dim y As Long 
 Dim vCont As Variant 
 Dim rDelete As Range 
 dtFrom = Sheets（Control Panel）。Range（D5）。value 
 dtUpto = dtFrom + 6 
 Sheet1.Range（D1）。Value2 =扫描，请稍候。 
带表格（数据库）
对于y = Sheet5.Cells（Sheet5.Rows.Count，2）.End（xlUp）.Row + 1到2 Step -1 
 vCont = .Cells（y，1）.Value 
如果不是IsError（vCont）然后
如果vCont> = dtFrom和vCont <= dtUpto然后
如果rDelete不是然后
设置rDelete = .Rows（y）
 Else 
设置rDelete =联合（rDelete，.Rows（y））
结束如果
结束如果
结束如果
下一个
结束
如果不是rDelete没有，然后rDelete.EntireRow.Delete 
'---恢复计算：
 Application.Calculation = xlAutomatic 
 End Sub 
  

注意：您也可以在这里使用自动过滤器。

I have a several macros within my workbook. This is the only one that seems to be really slow 3-5 minutes on a 2500 row sheet.

The purpose is if Row is between date dtFrom and dtUpTo Then delete entire row.

I added to pause and resume calculations and that boosted it slightly

Anyone have any ideas on how to make this faster?

Sub DeleteRows
    '--- Pause Calculations:
    Application.Calculation = xlManual
    '----- DELETE ROWS -----
    Dim dtFrom As Date
    Dim dtUpto As Date
    Dim y As Long
    Dim vCont As Variant
    dtFrom = Sheets("Control Panel").Range("D5").Value
    dtUpto = dtFrom + 6
    Sheet1.Range("D1").Value2 = "Scanning, Please wait..."
    With Sheets("Database")
        For y = Sheet5.Cells(Sheet5.Rows.Count, 2).End(xlUp).Row + 1 To 2   Step -1
            vCont = .Cells(y, 1).Value
            If Not IsError(vCont) Then
                If vCont >= dtFrom And vCont <= dtUpto Then
                    .Rows(y).EntireRow.Delete
                End If
            End If
        Next
    End With
    '--- Resume Calculations:
    Application.Calculation = xlAutomatic
   End Sub

Thanks!

解决方案

Try only doing one delete operation on all the relevant rows at the end:

Sub DeleteRows()
'--- Pause Calculations:
    Application.Calculation = xlManual
    '----- DELETE ROWS -----
    Dim dtFrom                As Date
    Dim dtUpto                As Date
    Dim y                     As Long
    Dim vCont                 As Variant
    Dim rDelete As Range
    dtFrom = Sheets("Control Panel").Range("D5").Value
    dtUpto = dtFrom + 6
    Sheet1.Range("D1").Value2 = "Scanning, Please wait..."
    With Sheets("Database")
        For y = Sheet5.Cells(Sheet5.Rows.Count, 2).End(xlUp).Row + 1 To 2 Step -1
            vCont = .Cells(y, 1).Value
            If Not IsError(vCont) Then
                If vCont >= dtFrom And vCont <= dtUpto Then
                    If rDelete Is Nothing Then
                        Set rDelete = .Rows(y)
                    Else
                        Set rDelete = Union(rDelete, .Rows(y))
                    End If
                End If
            End If
        Next
    End With
    If Not rDelete Is Nothing Then rDelete.EntireRow.Delete
    '--- Resume Calculations:
    Application.Calculation = xlAutomatic
End Sub

Note: You could also use an autofilter here.

这篇关于删除行缓慢的过程 - 如何做得更快？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！