快速删除空行遍历文件夹中的所有工作簿

Question

我在一个文件夹中有 200 多个工作簿，我通过在代码中提供一个范围为 Set rng = sht.Range("C3:C50000") 来删除空行。

如果Column C 任何单元格为空，则删除整个行。日复一日的数据正在增强，下面的代码需要将近半个小时才能完成处理。这个时间限制也随着数据的增加而增加。

我正在寻找一种在几分钟或更短的时间内完成此操作的方法。我希望能得到一些帮助。

Sub Doit()
    Dim xFd         As FileDialog
    Dim xFdItem     As String
    Dim xFileName   As String
    Dim wbk         As Workbook
    Dim sht         As Worksheet
    
    Application.ScreenUpdating = FALSE
    Application.DisplayAlerts = FALSE
    
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    If xFd.Show Then
        xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
    Else
        Beep
        Exit Sub
    End If
    xFileName = Dir(xFdItem & "*.xlsx")
    Do While xFileName <> ""
        Set wbk = Workbooks.Open(xFdItem & xFileName)
        For Each sht In wbk.Sheets
            
            Dim rng As Range
            Dim i   As Long
            Set rng = sht.Range("C3:C5000")
            With rng
                'Loop through all cells of the range
                'Loop backwards, hence the "Step -1"
                For i = .Rows.Count To 1 Step -1
                    If .Item(i) = "" Then
                        'Since cell Is empty, delete the whole row
                        .Item(i).EntireRow.Delete
                    End If
                Next i
            End With
    
        Next sht
        wbk.Close SaveChanges:=True
        xFileName = Dir
    Loop

    Application.ScreenUpdating = TRUE
    Application.DisplayAlerts = TRUE
End Sub

Answer 1

这就是我将如何实施我的建议

1. 将要删除的行收集到单个范围中并在循环后删除。
2. 在隐藏窗口中打开工作簿，这样用户就不会被文件打开和关闭所打扰。 （打开文件时速度也会小幅提升）
3. 动态定义搜索范围以适合每个文件的数据，避免浪费时间搜索空白范围。

Sub Doit()
    Dim xFd         As FileDialog
    Dim xFdItem     As String
    Dim xFileName   As String
    Dim wbk         As Workbook
    Dim sht         As Worksheet
    Dim xlApp       As Object
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    If xFd.Show Then
        xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
    Else
        Beep
        Exit Sub
    End If
    xFileName = Dir(xFdItem & "*.xlsx")
    Set xlApp = CreateObject("Excel.Application." & CLng(Application.Version))
    
    Do While xFileName <> ""
        Set wbk = xlApp.Workbooks.Open(xFdItem & xFileName)
        For Each sht In wbk.Sheets
            
            Dim rng As Range
            Dim rngToDelete As Range
            Dim i   As Long
            Dim LastRow as Long
            LastRow = sht.Cells.Find("*", SearchDirection:=xlPrevious).Row
            Set rng = sht.Range("C3:C" & LastRow)
            With rng
                'Loop through all cells of the range
                'Loop backwards, hence the "Step -1"
                For i = .Rows.Count To 1 Step -1
                    If .Item(i) = "" Then
                        'Since cell Is empty, delete the whole row
                        If rngToDelete Is Nothing Then
                            Set rngToDelete = .Item(i)
                        Else
                            Set rngToDelte = Union(rngToDelete, .Item(i))
                        End If
                    End If
                Next i
            End With
            If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete
        Next sht
        wbk.Close SaveChanges:=True
        xFileName = Dir
    Loop
    xlApp.Quit
    Set xlApp = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

我使用CreateObject 创建一个新的excel 应用程序，我使用Application.Version，所以新的excel 应用程序与当前的相同。我在使用 New Excel.Application 创建对象时遇到了不好的体验，因为它有时会被重定向到 excel 365 演示，或者安装在计算机上但不打算使用的其他版本的 excel。

Answer 2

试试这个更快的删除行：

Sub Doit()
    Dim xFd         As FileDialog
    Dim xFdItem     As String
    Dim xFileName   As String
    Dim wbk         As Workbook
    Dim sht         As Worksheet
    
    Application.ScreenUpdating = FALSE
    Application.DisplayAlerts = FALSE
    
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    If xFd.Show Then
        xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
    Else
        Beep
        Exit Sub
    End If
    
    xFileName = Dir(xFdItem & "*.xlsx")
    Do While xFileName <> ""
        Set wbk = Workbooks.Open(xFdItem & xFileName)
        For Each sht In wbk.WorkSheets 'Sheets includes chart sheets... 
            On Error Resume Next  'in case of no blanks  
            sht.Range("C3:C5000").specialcells(xlcelltypeblanks).entirerow.delete
            On Error Goto 0
        Next sht
        wbk.Close SaveChanges:=True
        xFileName = Dir()
    Loop

    Application.ScreenUpdating = TRUE
    Application.DisplayAlerts = TRUE
End Sub

请注意，尽管您最大的时间消耗可能仍然是打开和保存/关闭所有文件。

Answer 3

参考过滤列

函数

Option Explicit

Function RefFilteredColumn( _
    ByVal ColumnRange As Range, _
    ByVal Criteria As String) _
As Range
    Const ProcName As String = "RefFilteredColumn"
    On Error GoTo ClearError
    
    Dim ws As Worksheet: Set ws = ColumnRange.Worksheet
    If ws.AutoFilterMode Then
        ws.AutoFilterMode = False
    End If
    
    Dim crg As Range: Set crg = ColumnRange.Columns(1)
    Dim cdrg As Range: Set cdrg = crg.Resize(crg.Rows.Count - 1).Offset(1)
    
    crg.AutoFilter 1, Criteria, xlFilterValues
    
    On Error Resume Next
    Set RefFilteredColumn = cdrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo ClearError
    
    ws.AutoFilterMode = False
    
ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function

在您的代码中使用

    For Each sht In wbk.Worksheets
        ' The header row ('C2', not 'C3') is needed when using 'AutoFilter'.
        Dim rng As Range: Set rng = sht.Range("C2:C5000")
        Dim frg As Range: Set frg = RefFilteredColumn(rng, "")
        If Not frg Is Nothing Then
            frg.EntireRow.Delete
            Set frg = Nothing
        ' Else ' no blanks
        End If
    Next sht