VBA. Deleting multiple cells in a row if one cell is blank

Question

I have multiple columns in an excel sheet...say A1:D10. I want to find any blank cells in column C, delete that cell as well as the A,B, and D cells of that same row, then shift up. But only in the range of A1:D10. I have other information in this excel sheet outside this range that I want to perserve in its original position. Therefore I can not use somthing like this:

.SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Nor can I get something like the following to work, because it only shifts the single column up, not all four columns.

Set rng = Range("A1:D10").SpecialCells(xlCellTypeBlanks)
rng.Rows.Delete Shift:=xlShiftUp

Answer 1

If there is no data in columns A to D below row 10 that you don't want to move up, then SpecialCells and Delete Shift Up can be used like this

Sub Demo1()
    Dim ws As Worksheet
    Dim TestColumn As Long
    Dim StartColumn As Long
    Dim EndColumn As Long
    Dim FirstRow As Long
    Dim LastRow As Long

    Dim i As Long
    Dim rng As Range, arr As Range

    ' set up reference data
    Set ws = ActiveSheet '<~~ update as required
    TestColumn = 3  'C
    StartColumn = 1 'A
    EndColumn = 4   'D
    FirstRow = 1
    LastRow = 10

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    With ws
        On Error Resume Next
            Set rng = .Range(.Cells(FirstRow, TestColumn), .Cells(LastRow, TestColumn)).SpecialCells(xlCellTypeBlanks)
        On Error GoTo 0

        If Not rng Is Nothing Then
            For Each arr In rng.Areas
                arr.EntireRow.Resize(, EndColumn - StartColumn + 1).Delete Shift:=xlShiftUp
            Next
        End If
    End With
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

If there is data in columns A to D below row 10 that you don't want to move up, then you can use Cut and Paste, like this

Sub Demo()
    Dim ws As Worksheet
    Dim TestColumn As Long
    Dim StartColumn As Long
    Dim EndColumn As Long
    Dim FirstRow As Long
    Dim LastRow As Long

    Dim i As Long

    ' set up reference data
    Set ws = ActiveSheet '<~~ update as required
    TestColumn = 3  'C
    StartColumn = 1 'A
    EndColumn = 4   'D
    FirstRow = 1
    LastRow = 10

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    With ws
        If IsEmpty(.Cells(LastRow, TestColumn)) Then
            .Cells(LastRow, StartColumn).Resize(1, EndColumn - StartColumn + 1).Clear
        End If
        For i = LastRow - 1 To FirstRow Step -1
            If IsEmpty(.Cells(i, TestColumn)) Then
                .Range(.Cells(i + 1, StartColumn), .Cells(LastRow, EndColumn)).Cut .Cells(i, StartColumn)
            End If
        Next
    End With
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Answer 2

Using Variant Array Method

Sub test2()
    Dim rngDB As Range, vDB As Variant
    Dim i As Integer, j As Integer, n As Integer
    Dim k As Integer

    Set rngDB = Range("a1:d10")

    vDB = rngDB

    n = UBound(vDB, 1)
    For i = 1 To n
        If IsEmpty(vDB(i, 3)) Then
            For j = 1 To 4
                If j <> 3 Then
                    vDB(i, j) = Empty
                End If
            Next j
        End If
    Next i
    For j = 1 To 4
        If j <> 3 Then
            For i = 1 To n - 1
                For k = i To n - 1
                    If vDB(k, j) = Empty Then
                        vDB(k, j) = vDB(k + 1, j)
                        vDB(k + 1, j) = Empty
                    End If
                Next k
            Next i
        End If
    Next j
    rngDB = vDB
End Sub

Answer 3

The below will take care of your requirement by looking for an empty cell in column 3, and deleting the row and shifting up only in that row.

Sub deleteEmptyRow()
Dim i As Integer

    For i = 1 To 10
        If Cells(i, 3) = "" Then
            Range(Cells(i, 1), Cells(i, 4)).delete Shift:=xlUp
        End If
    Next i

End Sub