search for specific string and delete all cells in between vertically

Question

I want to create a VBA function that searches for the term red and deletes all remaining cells empty cells between Red. As you can see in the photo column c represents the desired outcome. My code below right now deletes all empty spaces between the cells in a vertical way. I just need to add the search for red part to this code.

Sub collapse_columns()
    Dim x As Integer
    For x = 1 To 4
        collapse_column x
    Next
End Sub


Sub collapse_column(column_number As Integer)

    Dim row As Long
    Dim s As Worksheet
    Dim last_row As Long
    Set s = ActiveSheet ' work on the active sheet
    'Set s = Worksheets("Sheet1") 'work on a specific sheet
    
    last_row = ActiveSheet.Cells(s.Rows.Count, column_number).End(xlUp).row
    
    For row = last_row To 1 Step -1
      If Cells(row, column_number).Value = "" Then Cells(row, column_number).Delete xlUp
    Next

End Sub

Answer 1

Using autofilter you can avoid looping and deleting rows one by one.

    Application.DisplayAlerts = False
    With ActiveSheet
        .Rows(1).EntireRow.Insert 'If you have headers you don't need
        .Cells(1, 1).Value = "Temp" 'If you have headers you don't need
        .Cells(1, 1).AutoFilter 1, "<>red"
        
        'If you have headers start on row 2
        .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeVisible).Delete
        If .FilterMode Then
            .ShowAllData
        End If
    End With
    Application.DisplayAlerts = True

If you want to just modify your existing code change this line:

If Cells(row, column_number).Value = "" Then Cells(row, column_number).Delete xlUp

to:

If Not Cells(row, column_number).Value Like "red" Then Cells(row, column_number).Delete xlUp