Select variable blank cell range in column in VBA

Question

I have a code that contains blank cells throughout a certain column. I want to be able to select the unknown length of only blank cells (offset 2 columns). I currently have multiple if statements that are filtered based on how many blanks, but the variable number of blanks could make this too complex.

Example: When it encounters these two blanks (6 & 7) I want to concatenate the contents, two columns to the right, of those rows (6 & 7) and paste in the cell above and one column to the right of the revisions/comments/blanks (and then I delete the row(s) of revisions/comments, so here, 6 & 7 get deleted). I have this part figured out, shown from picture 1 to 2 .

These blank cells occur randomly throughout and are variable in length, sometimes there are no revisions/comments, sometimes two rows, five rows, etc...

So rather than having many many if statements for how ever many rows are revisions/comments, I am looking for code that can select any variable length of blank cells and transfer that information all to one cell (the one directly to the right of the original line of information).

Here is the part of my code that does this so far:

Sub BlankCell()

'Delete all header rows (except top row)
Dim i, LastRow As Integer
i = 2
LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
Do While i <= LastRow
    If Cells(i, 2).Value = "Line" Then
        Rows(i).EntireRow.Delete
    End If
    i = i + 1
Loop

'Select first cell
Range("C2").Select

'Loop through column C to find empty cells
'Copy and paste column E contents (concatenated) to column F and delete row(s) of clarifications
Do While Not IsEmpty("C")

    'If there are three rows of comments
    If IsEmpty(ActiveCell.Offset(1, 0)) And IsEmpty(ActiveCell.Offset(2, 0)) Then
        Range(ActiveCell.Offset(0, 2), Range(ActiveCell.Offset(1, 2), ActiveCell.Offset(2, 2))).Select
        ActiveCell.Offset(-1, 1) = ActiveCell.Offset(0, 0).Value & Chr(10) & ActiveCell.Offset(1, 0).Value & Chr(10) & ActiveCell.Offset(2, 0).Value
        Selection.EntireRow.Delete
    'If there are two rows of comments
    ElseIf IsEmpty(ActiveCell.Offset(1, 0)) Then
        Range(ActiveCell.Offset(0, 2), ActiveCell.Offset(1, 2)).Select
        ActiveCell.Offset(-1, 1) = ActiveCell.Offset(0, 0).Value & Chr(10) & ActiveCell.Offset(1, 0).Value
        Selection.EntireRow.Delete
    'If there is one row of comments
    Else
        ActiveCell.Offset(0, 2).Select
        ActiveCell.Offset(-1, 1) = ActiveCell.Offset(0, 0).Value
        Selection.EntireRow.Delete
End If

'Find next blank in column C
NextBlank = Range("C1:C" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("C" & NextBlank).Select

'Exit loop once to the end of the table
If IsEmpty(ActiveCell.Offset(0, -1)) And IsEmpty(ActiveCell.Offset(1, -1)) Then
    Exit Do
End If

Loop

End Sub

Thanks in advance!

Answer 1

Try this. The pictures show the before and after so you can check if it's correct. You'll probably need to adjust the details for your precise set up.

This uses SpecialCells to loop through the blank areas and concatenate the corresponding cells before deleting the Area (a contiguous block of empty cells).

Sub BlankCell()

Dim j As Long, s As String, r As Range

With Columns("C").SpecialCells(xlCellTypeBlanks)
    For j = .Areas.Count To 1 Step -1
        For Each r In .Areas(j)
            s = s & r.Offset(, 1) & vblf
        Next r
        .Areas(j)(1).Offset(-1, 2) = Trim(s)
        s = vbNullString
        .Areas(j).EntireRow.Delete
    Next j
End With

End Sub

BEFORE

AFTER