Delete Cells in excel and move contents up based on value - vba

Question

I've got some code working to condense multiple columns in excel, removing any blank cells and shunting the data upwards.
Every cell contains formulae, I did find a code snippet that let me use a specialcells command, but that only removed truly blank cells and not ones that contained a formula, where the outcome would make the cell blank.
This is what I'm currently using, which was an edit of something I found on this site a while ago:
Sub condensey()
Dim c As Range
Dim SrchRng
Set SrchRng = ActiveSheet.Range("B2", ActiveSheet.Range("B208").End(xlUp))
Do
Set c = SrchRng.Find("", LookIn:=xlValues)
If Not c Is Nothing Then c.Delete
Loop While Not c Is Nothing
End Sub
I tried increasing the range on the active sheet to include a second column, but excel just goes nuts, assuming it's trying to do it for every cell in the entire table.
I've then repeated this piece of code for each column that I want to condense.
Now this is great, it does exactly what I want to do, but it is slow as anything, especially when each column can contain up to 200+ rows. Any ideas on how to improve the performance of this, or maybe re-write it using a different method?

Answer 1

This ran in <1sec on 300rows x 3cols
Sub DeleteIfEmpty(rng As Range)
Dim c As Range, del As Range
For Each c In rng.Cells
If Len(c.Value) = 0 Then
If del Is Nothing Then
Set del = c
Else
Set del = Application.Union(del, c)
End If
End If
Next c
If Not del Is Nothing Then del.Delete
End Sub

Answer 2

I found that using AutoFilter on each column was faster than looping through each cell in the range or "Find"ing each blank cell in the range. Using the code below and some sample data (3 columns with approximately 300 rows of blank and non blank cells), on my machine it took 0.00063657 days. Using the loop through each cell method, it took 0.00092593 days. I also ran your code on the sample data, and it took a lot longer (I didn't let it finish). So far, the method below yields the quickest results, though I imagine someone will find a faster method.
It appears that the delete method is the biggest bottleneck. It may be fastest to filter the non-blank cells and paste them into a new range, and then delete the old range once you're finished.
Sub condensey2()
Dim c As Range
Dim tbl As Range, tblWithHeader As Range, tblEnd As Range, delRng As Range
Dim i As Long
Dim maxRows As Long
Dim t As Double
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ActiveSheet.Calculate
maxRows = ActiveSheet.Rows.Count
ActiveSheet.AutoFilterMode = False
With ActiveSheet
Set tblEnd = Range(.Cells(maxRows, 1), .Cells(maxRows, 3)).End(xlUp)
Set tbl = Range(.Cells(2, 1), Cells(tblEnd.Row, 3))
End With
t = Now()
Set tblWithHeader = tbl.Offset(-1).Resize(tbl.Rows.Count + 1)
i = 1
For i = 1 To tbl.Columns.Count
With tblWithHeader
.AutoFilter
.AutoFilter field:=i, Criteria1:="="
End With
Set delRng = tbl.Columns(i).Cells.SpecialCells(xlCellTypeVisible)
ActiveSheet.AutoFilterMode = False
delRng.Delete xlShiftUp
'redefine the table to make it smaller to make the filtering efficient
With ActiveSheet
Set tblEnd = Range(.Cells(maxRows, 1), .Cells(maxRows, 3)).End(xlUp)
Set tbl = Range(.Cells(2, 1), Cells(tblEnd.Row, 3))
End With
Set tblWithHeader = tbl.Offset(-1).Resize(tbl.Rows.Count + 1)
Next i
t = Now() - t
Debug.Print Format(t, "0.00000000")
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub