Another one, should be very fast...
Sub test() Dim a, i&, ii&, iii As Long, n& With Columns(1).SpecialCells(2).Areas(1).CurrentRegion a = .Value2 For ii = 1 To UBound(a, 2) n = 0: iii = 0 For i = UBound(a, 1) To 1 Step -1 If a(i, ii) = "" Then n = n + 1 Else Exit For End If Next If n Then For i = UBound(a, 1) - n To 1 Step -1 a(UBound(a, 1) - iii, ii) = a(i, ii) iii = iii + 1 If i <= n Then a(i, ii) = "" Next End If Next .Value2 = a End With End Sub