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

Question

我在一个文件夹中有 200 多个工作簿，我通过在代码中提供一个 Range 来删除空行 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

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

将要删除的行收集到单个范围中并在循环后删除。

在隐藏窗口中打开工作簿，这样用户就不会受到文件打开和关闭的干扰。 (打开文件时速度也会小幅提升)

动态定义您的搜索范围以适合每个文件的数据，消除浪费时间搜索空白范围。

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。