Deleting entire columns based on column headers

Question

I am trying to delete all the columns in an Excel sheet except the columns with the headers of "Product code" "Size" and "Quantity".

I have written the following code.

Sub delcolumns()
    Dim Rng As Range
    Dim cell As Range
    Set Rng = Range(("A1"), Range("A1").End(xlToRight))
    For Each cell In Rng
        If cell.Value <> "Product Code" Or "Size" Or "Quantity" Then cell.EntireColumn.Delete
        Next cell
End Sub

After running the micro the error says "Type mismatch"

Answer 1

Write back a resized array without backward loops

In addition to the valid solutions above and in order to show an alternative approach using the advanced features of the Application.Index function: all actions are executed within an array before writing it back to sheet.

Method

The Application.Index function allows not only to receive row and column numbers as arguments, but also row and column arrays with certain restructuring possibilities. The rows array contains the complete set of rows, the column array is built by a helper function getColNums() containing the related column numbers to the wanted titles "Product code", "Size" and "Quantity". - You might find some interesting pecularities of this function at Insert first column in datafield array without loops or API call.

Code example

This code example assumes a data range A1:F1000 which can be changed easily to your needs.

Sub RestructureColumns()
  Dim rng As Range, titles(), v
  titles = Array("Product code", "Size", "Quantity")            ' << define wanted column titles
  Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1:F1000") ' << change to wanted sheet and data range
' [1a] create 2-dim data field array (1-based)
  v = rng.Value2
' [1b] filter out columns to be deleted, i.e. maintain the rest
  v = Application.Index(v, Evaluate("row(1:" & rng.Rows.count & ")"), getColNums(v, titles))
' [2] write data field back to resized range
  rng = ""                                  ' clear lines
  rng.Resize(UBound(v), UBound(v, 2)) = v   ' write back only columns with predefined titles
End Sub

'Helper function getColNums()

Function getColNums(v, titles) As Variant()
' Purpose: return array of column numbers related to wanted titles, e.g. 1st, 3rd and 6th column
  Dim tmpAr, title, foundCol, i&                                        ' declare variables
  ReDim tmpAr(0 To UBound(titles))                                      ' dimension array to titles length
  For Each title In titles                                              ' check the wanted titles only ...
     foundCol = Application.Match(title, Application.Index(v, 1, 0), 0) ' ... against the complete title row
     If Not IsError(foundCol) Then tmpAr(i) = foundCol:   i = i + 1     ' if found add col no, increment counter
  Next title
  ReDim Preserve tmpAr(0 To i - 1)                                      ' (redundant if all titles available)
  getColNums = tmpAr                                                    ' return built array
End Function

Answer 2

You won't have to delete backwards using this code. This method tends to be more efficient since the actions are outside of the loop.

Say that you have 20 columns and intend to delete 17 of them (keep your 3 columns that are needed). This means you will have 17 iterations of columns being deleted and rows being shifted.

Instead, keep track of your target columns to delete using Union (collection of cells) and then delete everything all at once outside of the loop. No matter how many columns you have to be deleted, you will always do it all in once instance rather n instances. The larger the number of columns to be deleted, the greater the gains from using this method.

---

Option Explicit

Sub DeleteMe()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") '<-- Update sheet
Dim LC As Long, MyHeader As Range, DeleteMe As Range
LC = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

For Each MyHeader In ws.Range(ws.Cells(1, 1), ws.Cells(1, LC))
    Select Case MyHeader
        Case "Product code", "Size", "Quantity"
        Case Else
            If Not DeleteMe Is Nothing Then
                Set DeleteMe = Union(DeleteMe, MyHeader)
            Else
                Set DeleteMe = MyHeader
            End If
    End Select
Next MyHeader

If Not DeleteMe Is Nothing Then DeleteMe.EntireColumn.Delete

End Sub

Answer 3

You should work backwards when deleting rows or columns or you risk skipping over one or more.

Sub delcolumns()

    Dim c as long, cols as variant

    cols = array("Product Code", "Size", "Quantity")

    for c = cells(1, columns.count).end(xltoleft).column to 1 step -1
        if iserror(application.match(cells(1, c).value, cols, 0)) then
             columns(c).entirecolumn.delete
        end if
    next c

End Sub

'alternative
Sub delcolumns()

    Dim c as long

    for c = cells(1, columns.count).end(xltoleft).column to 1 step -1
        select case cells(1, c).value
            case "Product Code", "Size", "Quantity"
                'do nothing
            case else
                columns(c).entirecolumn.delete
        end select
    next c

End Sub

As far as your own code code, there are a couple of problems.

If cell.Value <> "Product Code" Or "Size" Or "Quantity" Then cell.EntireColumn.Delete

The above line is improper syntax. Each criteria needs to be written out longhand.

If cell.Value <> "Product Code" Or cell.Value <> "Size" Or cell.Value <> "Quantity" Then cell.EntireColumn.Delete

See Is variable required instead of “or” for alternatives.

More importantly, your logic is flawed. If one column is Product Code, then it isn't Size or Quantity and it will get deleted. You actually want,

If cell.Value <> "Product Code" AND cell.Value <> "Size" AND cell.Value <> "Quantity" Then cell.EntireColumn.Delete

Using And instead of Or means that the column is none of the three then delete.