如何加快 Q 列有空白单元格时删除行的 vba 代码

问题描述 投票:0回答:3

我有一张近 100000 行和列 A 到 Q 的工作表 我有一个代码,如果 Q 列有空白单元格,则删除整行。

我已经在 4000 行上尝试过这段代码,它在 3 分钟内运行,但当我处理 100000 行时,它只处理几个小时。

如果有人帮助/指导我加快这段代码,我将非常高兴。

代码是:

Sub DeleteBlank()
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual 
    
    Dim lo As ListObject
    set lo = sheets("BOM 6061").ListObjects(1)
    Sheets("BOM 6061").Activate
    
    lo.AutoFilter.ShowAllData
    lo.range.AutoFilter Field:=17, Criteria1:=""
    
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationAutomatic
    
    lo.DataBodyRange.SpecialCells(xlCellsTypeVisible).Delete
    
    Application.DisplayAlerts = True
    lo.AutoFilter.ShowAllData
End Sub
excel vba processing-efficiency excel-tables listobject
3个回答
1
投票

高效删除 Excel 表格中的条件行

  • 简而言之,如果不对条件列进行排序,删除行可能会“永远”。
  • 下面的代码将做到这一点,并保持剩余行的初始顺序。
Option Explicit

Sub DeleteBlankRows()
    
    Const wsName As String = "BOM 6061"
    Const tblIndex As Variant = 1
    Const CriteriaColumnNumber As Long = 17
    Const Criteria As String = ""
    
    ' Reference the table.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    Dim tbl As ListObject: Set tbl = ws.ListObjects(tblIndex)
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' Remove any filters.
    If tbl.ShowAutoFilter Then
        If tbl.AutoFilter.FilterMode Then tbl.AutoFilter.ShowAllData
    Else
        tbl.ShowAutoFilter = True
    End If
    
    ' Add a helper column and write an ascending integer sequence to it.
    Dim lc As ListColumn: Set lc = tbl.ListColumns.Add
    lc.DataBodyRange.Value = _
        ws.Evaluate("ROW(1:" & lc.DataBodyRange.Rows.Count & ")")
    
    ' Sort the criteria column ascending.
    With tbl.Sort
        .SortFields.Clear
        .SortFields.Add2 tbl.ListColumns(CriteriaColumnNumber).Range, _
            Order:=xlAscending
        .Header = xlYes
        .Apply
    End With

    ' AutoFilter.
    tbl.Range.AutoFilter Field:=CriteriaColumnNumber, Criteria1:=Criteria
    
    ' Reference the filtered (visible) range.
    Dim svrg As Range
    On Error Resume Next
        Set svrg = tbl.DataBodyRange.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    ' Remove the filter.
    tbl.AutoFilter.ShowAllData
  
    ' Delete the referenced filtered (visible) range.
    If Not svrg Is Nothing Then svrg.Delete
    
    ' Sort the helper column ascending.
    With tbl.Sort
        .SortFields.Clear
        .SortFields.Add2 lc.Range, Order:=xlAscending
        .Header = xlYes
        .Apply
        .SortFields.Clear
    End With
    
    ' Delete the helper column.
    lc.Delete
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    ' Inform.
    MsgBox "Blanks deleted.", vbInformation
    
End Sub

0
投票

我不会在大型数据集上使用自动过滤器,因为在实际过滤数据之前,它们可能需要花费相当多的时间来尝试枚举可用选项。 AutoFilter.ShowAllData 花费同样多的时间。对于我的超级简单测试数据集(由 26 列、1000000 行组成),每个数据集的处理时间超过 30 秒。

据我所知,您正在过滤列表以仅显示空白项目,然后删除空白行。由于过滤是导致延迟的原因,我们可以循环遍历每一行,查看特定列,如果它为空,您可以将其删除。以下是如何执行此操作的示例。

**编辑:经过测试,我发现这比您想要的要慢得多。查看下面的下一个示例,因为它非常快。

Option Explicit

Sub DeleteBlank()

    Application.ScreenUpdating = False

    Dim calcType As Integer
    Dim rowCount, columnNumToCheck, currow, dataStartRow As Long
    Dim WkSht As String
    Dim lo As ListObject

    WkSht = "BOM 6061" 'The name of the worksheet where the table is located.
    columnNumToCheck = 17 'The column number to check for blank cells.

    calcType = Application.Calculation
    Application.Calculation = xlCalculationManual
    Set lo = Sheets(WkSht).ListObjects(1)
    rowCount = lo.ListRows.Count
    dataStartRow = (lo.DataBodyRange.Row - 1)

    For currow = rowCount To 1 Step -1
        If Sheets(WkSht).Cells((currow + dataStartRow), columnNumToCheck).Value = "" Then
            Call DeleteRows(WkSht, (currow + dataStartRow))
        End If
    Next currow

    Application.Calculation = calcType
    Application.ScreenUpdating = True

End Sub

Private Sub DeleteRows(sheetNameIn As String, startRow As Long, Optional optionalEndRow As Long)

    If IsNull(optionalEndRow) Or optionalEndRow = 0 Then
        optionalEndRow = startRow
    End If

    Worksheets(sheetNameIn).Range(startRow & ":" & optionalEndRow).Delete Shift:=xlUp

End Sub

如果您能够对空白单元格都在一起的数据进行排序,您可以使用下面的命令来执行单个删除功能,一次将它们全部删除。这在几秒钟内删除了 70000 行。

Sub DeleteBlankWithSort()

    'Application.ScreenUpdating = False

    Dim columnNumToCheck, tableLastRow, lrow As Long
    Dim calcType As Integer
    Dim WkSht As String
    Dim lo As ListObject

    WkSht = "BOM 6061" 'The name of the worksheet where the table is located.
    columnNumToCheck = 17 'The column number to check for blank cells.

    calcType = Application.Calculation
    Application.Calculation = xlCalculationManual
    Set lo = Sheets(WkSht).ListObjects(1)
                  
    tableLastRow = FindLastRow(WkSht, (columnNumToCheck))
    
    With lo.Sort
        .SortFields.Clear
        .SortFields.Add _
            Key:=Range("Table1[[#All],[q]]"), _
            SortOn:=xlSortOnValues, _
            Order:=xlDescending, _
            DataOption:=xlSortNormal
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    lrow = FindLastRow(WkSht, (columnNumToCheck), (tableLastRow))
    Call DeleteRows(WkSht, (tableLastRow), (lrow + 1))

    Application.Calculation = calcType
    Application.ScreenUpdating = True

End Sub

Private Sub DeleteRows(sheetNameIn As String, startRow As Long, Optional optionalEndRow As Long)

    If IsNull(optionalEndRow) Or optionalEndRow = 0 Then
        optionalEndRow = startRow
    End If

    Worksheets(sheetNameIn).Range(startRow & ":" & optionalEndRow).Delete Shift:=xlUp

End Sub

Private Function FindLastRow(sheetNameIn As String, columnNum As Long, Optional optionalStartRow As Long) As Long
'finds the last row of the column passed in the sheetname passed in
    
    If IsNull(optionalStartRow) Or optionalStartRow = 0 Then
        optionalStartRow = 1048576
    End If
    
    FindLastRow = Worksheets(sheetNameIn).Range(Cells(optionalStartRow, columnNum).Address).End(xlUp).Row
    
End Function

0
投票

不久前我有一个简单的例子。高级过滤是就地过滤或在 excel/vba 中过滤和复制的最快方法。在高级过滤中,您通常会在列/行中列出过滤器,并且可以根据需要设置多个过滤器,使用 >"" 过滤掉列上的空白,应该不需要任何时间。在我的示例中,它可能有所不同,因为如果过滤器中添加了任何内容,则它与sheetchange一起使用以自动过滤。

Sub Advanced_Filtering_ModV2()

Dim rc As Long, crc As Long, trc As Long
Dim wb As Workbook, ws As Worksheet
Set wb = ActiveWorkbook: Set ws = wb.Worksheets("sheet1")

ws.Range("AA1").Value = ws.Range("Q1").Value: ws.Range("AA2").Value = ">"""""

On Error Resume Next
ws.ShowAllData: rc = ws.Range("A" & Rows.Count).End(xlUp).Row

ws.Range("A1:V" & rc).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=ws.Range("AA1:AA2")
On Error GoTo 0

End Sub
© www.soinside.com 2019 - 2024. All rights reserved.