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

Question

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

Answer 1

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

Answer 2

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.

Answer 3

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