问如何在q列有空单元格时加速删除行的vba代码

EN

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

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

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

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