Delete Empty Rows Quickly Looping though all workbooks in Folder-CodePudding

I have more than 200 workbooks in an Folder, and i deletes the empty rows by giving an Range in the code that is Set rng = sht.Range("C3:C50000").

If Column C any cell is empty then delete entire Row. Day by day data is enhancing and below code took nearly half hour to complete the processing. That time limit is also increasing with the data.

I am looking for a way to to do this in couple of minutes or in less time. I hope to get some help.

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

CodePudding user response：

This is how I would implement my suggestions of

collecting the rows to delete into a single range and deleting after the loop.
opening the workbooks in a hidden window so the user is not disturbed by files opening and closing. (And also a minor speed boost when opening files)
Dynamically defining your search range to fit the data of each file, eliminating wasted time searching blank ranges.

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.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

I use CreateObject to create a new excel app, and I use Application.Version so the new excel app is the same as the current one. I have had bad experience using New Excel.Application to create the object because it sometimes gets redirected to an excel 365 demo, or some other version of excel that is installed on the computer but not intended for use.

CodePudding user response：

Try this for quicker row deletion:

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

Note though your biggest time sink may still be opening and saving/closing all the files.

CodePudding user response：

Reference Filtered Column

The Function

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

Use in Your Code

    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