Delete row if cell in changing column is blank

Question

This is is Excel 2010 on Windows 7.

I receive spreadsheets where one of the columns is called "Approved." This column is filled with x's and blanks. I want to delete all rows that have blanks in that column. This is a simple problem but has two confounding issues:

1. The location of the Approved column changes, so I can't just do Columns("R").SpecialCells(xlBlanks).EntireRow.Delete. I try to get around this by searching for "Approve" in A1:Z5 (since there are always fewer than 26 rows), and selecting the column in which it is found.
2. Much of the data is pulled from a previous month's document so some of the "blank" cells are populated with a vlookup. I try to get around this by first selecting all data and pasting as values.

Here is the current code:

Sub DeleteCol()
Range("A1").Select
Range(Selection, Selection.SpecialCells(xlLastCell)).Select
Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

  Dim rngApprove As Range
  Set rngApprove = Range("A1:Z5").Find("Approve")
  If rngApprove Is Nothing Then
    MsgBox "Approved column was not found."
    Exit Sub
  End If
  Dim approved_column As Range
  Set approved_column = rngApprove.EntireColumn
  approved_column.SpecialCells(xlBlanks).EntireRow.Delete
End Sub

The copy + paste as value works as intended. However, the row deletion only deletes rows 1-4 and leaves everything below row 5 alone, even though some of those cells are blank. If I replace the last line with

approved_column.select

it selects the whole column, as it should. This leads me to believe that the issue is with my deletion method.

Answer 1

If you have zero-length strings returned by formulas, it is not sufficient to revert the formula results to their values. You need to quickly sweep the column with a Range.TextToColumns method, using Fixed Width and returning the column's values back to their original cells to make the cells truly blank.

Sub DeleteCol()
    Dim iCOL As Long, sFND As String

    With ActiveSheet
        With .Range(.Cells(1, 1), .Cells(1, 1).SpecialCells(xlLastCell))
            .Value = .Value
        End With
        sFND = "Approve"

        If CBool(Application.CountIf(.Rows(1), sFND)) Then
            iCOL = Application.Match(sFND, .Rows(1), 0)
            If CBool(Application.CountBlank(.Columns(iCOL))) Then
                With .Columns(iCOL)
                    .TextToColumns Destination:=.Cells(1), DataType:=xlFixedWidth, _
                                   FieldInfo:=Array(0, 1)
                    .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                End With
            End If
        End If
    End With

End Sub

The worksheet's COUNTBLANK function will count zero-length strings in its blank count so we can determine whether there are blank cells before proceeding. The same goes for using the COUNTIF function to make sure that there is a column header with 'Approve' in the first row.

Answer 2

Try this (based on delete rows optimization solution)

Option Explicit

Sub deleteRowsWithBlanks()
    Const KEY_STRING As String = "Approve"
    Dim oldWs As Worksheet, newWs As Worksheet, rowHeights() As Long
    Dim wsName As String, rng As Range, filterCol As Long

    Set oldWs = ActiveSheet
    wsName = oldWs.Name
    Set rng = oldWs.Range("A1:Z5")
    filterCol = getHeaderColumn(rng, KEY_STRING, True)

    If filterCol > 0 Then
        FastWB True
        If rng.Rows.Count > 1 Then
            Set newWs = Sheets.Add(After:=oldWs)
            With oldWs.UsedRange
                .AutoFilter Field:=filterCol, Criteria1:="<>"
                .Copy
            End With
            With newWs.Cells
                .PasteSpecial xlPasteColumnWidths
                .PasteSpecial xlPasteAll
                .Cells(1, 1).Select
                .Cells(1, 1).Copy
            End With
            oldWs.Delete
            newWs.Name = wsName
        End If
        FastWB False
    End If
End Sub

---

Helper functions:

Public Function getHeaderColumn(ByVal rng As Range, ByVal headerName As String, _
                                Optional matchLtrCase As Boolean = True) As Long
    Dim found As Range, foundCol As Long

    If Not rng Is Nothing Then
        headerName = Trim(headerName)
        If Len(headerName) > 0 Then
            Set found = rng.Find(What:=headerName, MatchCase:=matchLtrCase, _
                                 LookIn:=xlFormulas, LookAt:=xlWhole)
            If Not found Is Nothing Then foundCol = found.Column
        End If
    End If
    getHeaderColumn = foundCol
End Function

---

Public Sub FastWB(Optional ByVal opt As Boolean = True)
    With Application
        .Calculation = IIf(opt, xlCalculationManual, xlCalculationAutomatic)
        .DisplayAlerts = Not opt
        .DisplayStatusBar = Not opt
        .EnableAnimations = Not opt
        .EnableEvents = Not opt
        .ScreenUpdating = Not opt
    End With
    FastWS , opt
End Sub

Public Sub FastWS(Optional ByVal ws As Worksheet = Nothing, _
                  Optional ByVal opt As Boolean = True)
    If ws Is Nothing Then
        For Each ws In Application.ActiveWorkbook.Sheets
            EnableWS ws, opt
        Next
    Else
        EnableWS ws, opt
    End If
End Sub
Private Sub EnableWS(ByVal ws As Worksheet, ByVal opt As Boolean)
    With ws
        .DisplayPageBreaks = False
        .EnableCalculation = Not opt
        .EnableFormatConditionsCalculation = Not opt
        .EnablePivotTable = Not opt
    End With
End Sub