VBA: Delete blank rows

[jimmy2times]

I work with data on a regular basis that is badly formatted. In the data set I have every alternate row is blank. Each week the amount of data will vary so there could be 500 rows or 10000 rows. Is there a macro i can run that that will start at the first row containing data (typically row 4) and end at the last row of data and delete the blank rows in between? It needs to take into account that the data range will be dynamic rather than static.

It is a pain to this manually and I am inexperienced with VBA.

Thank you

 

[Fishboy]

I work with data on a regular basis that is badly formatted. In the data set I have every alternate row is blank. Each week the amount of data will vary so there could be 500 rows or 10000 rows. Is there a macro i can run that that will start at the first row containing data (typically row 4) and end at the last row of data and delete the blank rows in between? It needs to take into account that the data range will be dynamic rather than static.

It is a pain to this manually and I am inexperienced with VBA.

Thank you

Hi jimmy2times,

The following code is something that forum moderator and MVP user Peter_SS shared with us a while back. So long as you don't ask me to explain how it works (you can find his own explanation HERE), then I think this will be the fastest and most efficient way I have seen so far for deleting blank rows. The code goes into a standard module and can either be applied to a button or accessed via the ALT+F8 macro window to be run:

Sub Del_Zero()
  Dim a, b
  Dim nc As Long, i As Long
 
  nc = Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlValues, SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, SearchFormat:=False).Column + 1
  a = Range("D1", Range("D" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If a(i, 1) = 0 Then b(i, 1) = 1
  Next i
  Application.ScreenUpdating = False
  With Range("A1").Resize(UBound(a), nc)
    .Columns(nc).Value = b
    .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo, _
          OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    On Error Resume Next
    .Columns(nc).SpecialCells(xlConstants).EntireRow.Delete
    On Error GoTo 0
  End With
  Application.ScreenUpdating = True
End Sub

 

[jimmy2times]

Thank you - I will give it a go