使用VBA删除Excel工作簿中C列为空的所有行

Question

我正在开展一个项目，为特定的导入规范清理几百张 excel 表。如果任何行的特定值为空白，则导入过程会出错，因此如果该行中的 C 列为空，我正在寻找删除整个工作簿中所有行的最佳方法。我发现这个在活动工作表上工作的简单 VBA 代码，但我需要它来遍历工作簿中的所有工作表。有什么关于更好的流程的建议，这样我就不必运行它 > 100 次了吗？

Sub DelBlankRows()
    Columns("C:C").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.EntireRow.Delete
End Sub

Answer 1

删除列的空白行

Option Explicit

Sub DelRowsOfColumnBlanksTEST()
    
    Const wsCol As Variant = "C" ' or 3
    'Const wsCol As String = "C"
    'Const wsCol As Long = 3
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Application.ScreenUpdating = False
    
    Dim ws As Worksheet
    For Each ws In wb.Worksheets
        DelRowsOfColumnBlanks ws, wsCol
    Next ws

    Application.ScreenUpdating = True

End Sub

Sub DelRowsOfColumnBlanks( _
        ByVal ws As Worksheet, _
        ByVal WorksheetColumnID As Variant)
    
    If ws Is Nothing Then Exit Sub ' no worksheet
        
    If ws.AutoFilterMode Then
        ws.AutoFilterMode = False
    End If
    
    Dim urg As Range: Set urg = ws.UsedRange
    If urg.Rows.Count = 1 Then Exit Sub ' only one row
    
    On Error Resume Next
    Dim crg As Range: Set crg = ws.Columns(WorksheetColumnID)
    On Error GoTo 0
    If crg Is Nothing Then Exit Sub ' invalid Worksheet Column ID
    
    Dim tcrg As Range: Set tcrg = Intersect(urg, crg)
    ' ... is only the same as 'Set tcrg = urg.Columns(WorkhseetColumnID)',...
    ' ... if the first column of the used range is column 'A'.
    If tcrg Is Nothing Then Exit Sub ' no intersection
    
    Dim drg As Range: Set drg = tcrg.Resize(tcrg.Rows.Count - 1).Offset(1)
                                                                                                                                                                        
    tcrg.AutoFilter 1, "=" ' ... covers blanks: 'Empty', "=""""", "'"... etc.
    
    ' Note that although it contains the word 'Blanks',...
    ' ... 'SpecialCells(xlCellTypeBlanks)' only covers 'Empty'.
    
    On Error Resume Next
    Dim spcrg As Range: Set spcrg = drg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Not spcrg Is Nothing Then
        spcrg.EntireRow.Delete
    'Else
        ' no 'visible' cells (to delete)
    End If
    
    ws.AutoFilterMode = False
    
End Sub

Answer 2

Option Explicit

Sub CleanWorkbook()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Worksheets
        DeleteRowsOfEmptyColumn sh, "C"
    Next
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Sub DeleteRowsOfEmptyColumn(sh As Worksheet, col as string)
    Dim rowsToDelete As New Collection
    Dim cell
    For Each cell In Intersect(sh.UsedRange, sh.Columns(col))
        If cell.Value = "" Then
            rowsToDelete.Add cell.Row
        End If
    Next
    
    Dim i As Integer
    For i = rowsToDelete.Count To 1 Step -1
        sh.Rows(rowsToDelete(i)).Delete
    Next
End Sub

Answer 3

我已经为任何在 C 中没有值的工作表设置了一个非常基本的错误陷阱。您可能需要自己改进它。

编辑：更新错误陷阱

    Sub DelBlankRows()
    
    Dim sh As Worksheet

    Application.ScreenUpdating = False
    
    On Error GoTo Handle
    For Each sh In ThisWorkbook.Worksheets
        sh.Activate
        Columns("C:C").Select
        Selection.SpecialCells(xlCellTypeBlanks).Select
        Selection.EntireRow.Delete
Cont:
    Next sh
    
    Application.ScreenUpdating = True
   
    Exit Sub

Handle:
    If Err.Number = 1004 Then Resume Cont
    
End Sub