Delete Cells in excel and move contents up based on value

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?

Have you turned off screenupdating and set calculation to manual? — Tim Williams, Jan 22 '14 at 18:08

Tim Williams · Answer 1 · 2014-01-22T23:17:01.440

2

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

edited Jan 22 '14 at 23:17

answered Jan 22 '14 at 18:11

Tim Williams

154,628
8
97
125

These answers are fantastic, thank you very much! Would upvote if I had the rep to do so! – GenericTechSupportAgent1 Jan 23 '14 at 10:41
+1 you could also try and do it with a loop (see [SO 15431801](http://stackoverflow.com/questions/15431801/how-to-delete-multiple-rows-without-a-loop-in-excel-vba) but it probably wouldn't be much faster – Our Man in Bananas Feb 19 '14 at 17:24

Will Ediger · Accepted Answer · 2014-01-22T19:05:40.503

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

Delete Cells in excel and move contents up based on value

2 Answers2