基于Blank Cell删除整行的最快方法

时间:2014-10-07 18:27:52

标签: excel vba

有很多方法可以根据特定列中的空白单元格删除整行。我想知道的是哪种是在Excel速度方面完成此任务的最快方法。我有一张包含大约39,000个原始数据行的表单,然后在运行下面的代码后变为21,000行。问题是代码块需要将近60秒才能返回。虽然我知道CPU等等是一个因素,但让我们假设其他条件相同。

我使用A列作为总行数,将F列作为空白单元格的位置。这是编写此代码的最佳/最快方式吗?

'查找带有文件编号的最后一行并删除剩余的行

Dim LastRow As Integer
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Range("F2:F" & LastRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

3 个答案:

答案 0 :(得分:0)

试试这个(希望它会有所帮助,尽管之前要备份你的表格!):

Sub FastestBlankRowTerminator()
ActiveSheet.UsedRange.Columns(6).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

答案 1 :(得分:0)

我设置了一个50,000行×12列的矩阵。在F栏中,我随机放置了大约25,000个空白。

  • 将使用的范围读入数组
  • 遍历数组并将包含F列内容的行读入结果数组
  • 清除原始数据
  • 编写结果数组

许多步骤,但执行时间不到一秒; screenupdating false可能会更快;如果您有更多列,则更长。

编辑: Screenupdating false并没有显着降低执行速度,使用高分辨率计时器计时约为0.36秒。

EDIT2:在阅读Tim Williams关于保留格式和公式的评论之后,我提出了一种不同的方法。这种方法将使用高级过滤器,并且在与上面相同的组成数据上,将数据放在另一个工作表上,减去列F中有空白的行。这确实需要数据中的第一行列标题;或者,至少F1有一个独特的非空白值。

完成该过程大约需要0.15秒。 如果您还想将其复制回原始工作表,并删除添加的工作表,则需要大约0.3秒。

以下是一些代码,但您必须根据自己的规格进行更改:

============================================== < / p>

Sub DeleteBlankFRows2()
    Dim WS As Worksheet, wsTemp As Worksheet, rTemp As Range
    Dim R As Range, rCrit As Range
    Dim I As Long
Set WS = Worksheets("Sheet5")
Set R = WS.Range("a1").CurrentRegion
Set rCrit = R.Offset(0, R.Columns.Count + 3).Resize(2, 1)
    rCrit(1) = R(1, 6)
    rCrit(2) = "<>"

Application.ScreenUpdating = False
Worksheets.Add
    Set wsTemp = ActiveSheet
    wsTemp.Name = "Temp"
    R.AdvancedFilter xlFilterCopy, rCrit, Cells(1, 1)
    Set rTemp = wsTemp.Cells(1, 1).CurrentRegion
WS.Cells.Clear
rTemp.Copy WS.Cells(1, 1)

Application.DisplayAlerts = False
wsTemp.Delete
Application.DisplayAlerts = True

Application.ScreenUpdating = True

End Sub

=======================================

这是我使用VBA数组的原始代码:

===========================

Sub foo()
    Dim vSrc As Variant, vRes() As Variant
    Dim rSrc As Range
    Dim I As Long, J As Long, K As Long
    Dim lRows As Long

'Or may need to use a different method to include everything
Set rSrc = Range("a1").CurrentRegion
vSrc = rSrc

'how many rows to retain
For I = 1 To UBound(vSrc)
    If vSrc(I, 6) <> "" Then lRows = lRows + 1
Next I

ReDim vRes(1 To lRows, 1 To UBound(vSrc, 2))
K = 0
For I = 1 To UBound(vSrc)
    If vSrc(I, 6) <> "" Then
        K = K + 1
        For J = 1 To UBound(vSrc, 2)
            vRes(K, J) = vSrc(I, J)
        Next J
    End If
Next I

Cells.Clear
Range("a1").Resize(UBound(vRes, 1), UBound(vRes, 2)) = vRes

End Sub

答案 2 :(得分:0)

我可以建议的最简单的事情之一应该是显着提高性能,这是在运行此程序时关闭屏幕更新和自动计算。

我通常会在最初调用代码时关闭这些项目,并在最后一次之后重新打开它们。意思是我将有一个子包含一系​​列其他子和函数,它将按顺序执行。我没有将它们单独嵌入到子组和函数中,而是将它们设置为关闭,执行主子组,然后重置它们。

' Speed Up
application.screenupdating = false
application.calculation = xlCalculationManual

<insert code you want to improve performance on here>    

' Slow Down
application.screenupdating = true
application.calculation = xlCalculationAutomatic

我自己运行了一个测试,自己填充了一个行数达到39000的列a,然后每个其他记录在列f中都有一个“1”。

我的core2duo仍需要一些时间,但只需46秒,如果我不关闭屏幕更新,则需要3分34秒。

Sub Main()
    ' Speed Up
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Begin ' Main Sub

    ' Reset
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Sub Begin()
    ' Sub 1
    ' Sub 2
    ' Sub 3
    Remove_Blanks
End Sub

Sub Remove_Blanks()
    Dim dA As Date, dB As Date
    Dim wb As Workbook
    Dim ws As Worksheet

    Dim i As Long, j As Integer
    Dim r As Long, c As Integer

    dA = Now

    ' Commented out to indicate they could be here but if you are executing multiple procedures then you should have it occur outside of this.
    'Application.ScreenUpdating = False  
    'Application.Calculation = xlCalculationManual

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet1")

    With ws
        For r = 1 To .UsedRange.Rows.Count
            If .Cells(r, 6) = "" Then .Rows(r).Delete
        Next r
    End With
    dB = Now

    'Commented out for same reason above
    'Application.ScreenUpdating = True
    'Application.Calculation = xlCalculationAutomatic

    Debug.Print "Remove_Blanks: " & Format((dB - dA), "mm/dd/yyyy hh:mm:ss")
End Sub