Remove random blanks and add alternate empty rows.

Artik said:

e.g.

VBA Code:

Sub RemoveAndInsertRows()
    Dim rngUnion As Range
    Dim rngSource As Range
    Dim lRow As Long
    Dim rngCell As Range
    Dim i As Long

    lRow = GetLastCell(ActiveSheet.UsedRange, xlByRows).Row

    Set rngSource = Range("R1", Cells(lRow, "R"))

    For Each rngCell In rngSource.Cells
        If IsEmpty(rngCell.Value) Then
            If Not rngUnion Is Nothing Then
                Set rngUnion = Union(rngUnion, rngCell)
            Else
                Set rngUnion = rngCell
            End If
        End If
    Next rngCell

    If Not rngUnion Is Nothing Then
        rngUnion.EntireRow.Delete
    End If


    For i = rngSource.Rows.Count To 2 Step -1
        Rows(i).Insert
    Next i

End Sub


Function GetLastCell(InRange As Range, SearchOrder As XlSearchOrder, _
                     Optional ProhibitEmptyFormula As Boolean = False) As Range
    ' By Chip Pearson,  www.cpearson.com
    Dim WS As Worksheet
    Dim R As Range
    Dim LastCell As Range
    Dim LastR As Range
    Dim LastC As Range
    Dim SearchRange As Range
    Dim LookIn As XlFindLookIn
    Dim RR As Range

    Set WS = InRange.Worksheet

    If ProhibitEmptyFormula = False Then
        LookIn = xlFormulas
    Else
        LookIn = xlValues
    End If

    Select Case SearchOrder
        Case XlSearchOrder.xlByColumns, XlSearchOrder.xlByRows, _
             XlSearchOrder.xlByColumns + XlSearchOrder.xlByRows
            ' OK
        Case Else
            Err.Raise 5
            Exit Function
    End Select

    With WS
        If InRange.Cells.Count = 1 Then
            Set RR = .UsedRange
        Else
            Set RR = InRange
        End If

        Set R = RR(RR.Cells.Count)

        If SearchOrder = xlByColumns Then
            Set LastCell = RR.Find(what:="*", after:=R, LookIn:=LookIn, _
                                   LookAt:=xlPart, SearchOrder:=xlByColumns, _
                                   SearchDirection:=xlPrevious, MatchCase:=False)
        ElseIf SearchOrder = xlByRows Then
            Set LastCell = RR.Find(what:="*", after:=R, LookIn:=LookIn, _
                                   LookAt:=xlPart, SearchOrder:=xlByRows, _
                                   SearchDirection:=xlPrevious, MatchCase:=False)
        ElseIf SearchOrder = xlByColumns + xlByRows Then
            Set LastC = RR.Find(what:="*", after:=R, LookIn:=LookIn, _
                                LookAt:=xlPart, SearchOrder:=xlByColumns, _
                                SearchDirection:=xlPrevious, MatchCase:=False)
            Set LastR = RR.Find(what:="*", after:=R, LookIn:=LookIn, _
                                LookAt:=xlPart, SearchOrder:=xlByRows, _
                                SearchDirection:=xlPrevious, MatchCase:=False)
            Set LastCell = Application.Intersect(LastR.EntireRow, LastC.EntireColumn)
        Else
            Err.Raise 5
            Exit Function
        End If
    End With

    Set GetLastCell = LastCell

End Function

Artik

Click to expand...

Artik said:

The image you attached shows data in column K, while my code operates on data in column R.

Artik

Click to expand...