VBA to Delete Excel Columns from a List

Question

I regularly download an excel file that has 1000+ columns, many of these are unwanted and manually deleting them is quite tedious. I found a VBA that will delete the unwanted columns but this method is not suited for a large list.

So, I have a workbook where Sheet1 is the data and columns run from A to BQM. I took all the header names and transposed them into column A in Sheet2 (A2:A1517). I think I'm looking for a way to have the vba look through the table in Sheet2 and delete any matching header titles on Sheet1. Any suggestions? I'm new at this so go slow.

Sub DeleteColumnByHeader()

    Set P = Range("A2:BQM2")

    For Each cell In P

        If cell.Value = "MAP Price" Then cell.EntireColumn.Delete

        If cell.Value = "Retail Price" Then cell.EntireColumn.Delete

        If cell.Value = "Cost" Then cell.EntireColumn.Delete

        If cell.Value = "Additional Specifications" Then cell.EntireColumn.Delete

    Next

End Sub

Answer 1

EDIT2: actually works now... EDIT: added re-positioning of matched columns

Using Match():

Sub DeleteAndSortColumnsByHeader()

    Dim wsData As Worksheet, wsHeaders As Worksheet, mHdr, n As Long
    Dim wb As Workbook, arr, rngTable As Range, addr
    Dim nMoved As Long, nDeleted As Long, nMissing As Long
    
    Set wb = ThisWorkbook 'for example
    Set wsData = wb.Sheets("Products")
    Set wsHeaders = wb.Sheets("Headers")
    
    'get array of required headers
    arr = wsHeaders.Range("A1:A" & _
                   wsHeaders.Cells(Rows.Count, "A").End(xlUp).Row).Value
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    'shift the data over so we can move columns into the required order
    Set rngTable = wsData.Range("a1").CurrentRegion 'original data
    addr = rngTable.Address                         'remember the position
    rngTable.EntireColumn.Insert
    Set rngTable = wsData.Range(addr)               'restore to position before insert
    
    'loop over the headers array
    For n = 1 To UBound(arr, 1)
        mHdr = Application.Match(arr(n, 1), wsData.Rows(1), 0) 'current position of this header
        If IsError(mHdr) Then
            'required header does not exist - do nothing, or add a column with that header?
            wsData.Cells(1, n).Value = arr(n, 1)
            nMissing = nMissing + 1
        Else
            wsData.Columns(mHdr).Cut wsData.Cells(1, n) 'found: move
            nMoved = nMoved + 1
        End If
    Next n
    
    'delete everything not found and moved
    With rngTable.Offset(0, rngTable.Columns.Count)
        nDeleted = Application.CountA(.Rows(1)) 'count remaining headers
        Debug.Print "Clearing: " & .Address
        .EntireColumn.Delete
    End With
    
    Application.Calculation = xlCalculationAutomatic
    Debug.Print "moved", nMoved
    Debug.Print "missing", nMissing
    Debug.Print "deleted", nDeleted
End Sub

Answer 2

In Sheet2 please clear the cells that display names of columns to delete. And run the below code.

Sub DeleteColumnByHeader()
    For Col = 1517 To 2 Step -1
        If Range("Sheet2!A" & Col).Value == "" Then
            Columns(Col).EntireColumn.Delete
        End If
    Next
End Sub

Answer 3

Delete Columns by Headers

• The DeleteColumnsByHeaders procedure will do the job.
• Adjust the values in the constants section.
• The remaining two procedures are here for easy testing.

Testing

• To test the procedure, add a new workbook and make sure it contains the worksheets Sheet1 and Sheet2.
• Add a module and copy the complete code to it.
• Run the PopulateSourceRowRange and the PopulateDestinationColumnRange procedures. Look at the worksheets to see the example setup.
• Now run the DeleteColumnsByHeaders procedure. Look at the Destination Worksheet (Sheet1) and see what has happened: all the unwanted columns have been deleted leaving only the 'hundreds'.

Option Explicit

Sub DeleteColumnsByHeaders()

    Const sName As String = "Sheet2"
    Const sFirst As String = "A2"
    
    Const dName As String = "Sheet1"
    Const dhRow As String = "A2:BQM2"

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Create a reference to the Source Column Range (unwanted headers).
    Dim srg As Range
    Dim srCount As Long
    With wb.Worksheets(sName).Range(sFirst)
        Dim slCell As Range
        Set slCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If slCell Is Nothing Then Exit Sub
        srCount = slCell.Row - .Row + 1
        Set srg = .Resize(srCount)
    End With
    
    ' Write the values from the Source Range to the Source Data Array.
    Dim sData As Variant
    If srCount = 1 Then
        ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
    Else
        sData = srg.Value
    End If
    
    ' Create a reference to the Destination Row Range.
    Dim drg As Range: Set drg = wb.Worksheets(dName).Range(dhRow)

    ' Combine all cells containing unwanted headers into the Union Range.
    Dim urg As Range
    Dim dCell As Range
    For Each dCell In drg.Cells
        If IsNumeric(Application.Match(dCell, sData, 0)) Then
            If urg Is Nothing Then
                Set urg = dCell
            Else
                Set urg = Union(urg, dCell)
            End If
        End If
    Next dCell
    
    Application.ScreenUpdating = False
    
    ' Delete the entire columns of the Union Range.
    If Not urg Is Nothing Then
        urg.EntireColumn.Delete
    End If
    
    Application.ScreenUpdating = True
    
End Sub

' Source Worksheet ('Sheet1'):
' Writes the numbers from 1 to 1807 into the cells of the row range
' and to five rows below.
Sub PopulateSourceRowRange()
    With ThisWorkbook.Worksheets("Sheet1").Range("A2:BQM2").Resize(6)
        .Formula = "=COLUMN()"
        .Value = .Value
    End With
End Sub

' Destination Worksheet ('Sheet2'):
' Writes the numbers from 1 to 1807 except the hundreds (100, 200,... 1800)
' to the range 'A2:A1790'. The hundreds are the columns you want to keep.
Sub PopulateDestinationColumnRange()
    Dim n As Long, r As Long
    r = 1
    With ThisWorkbook.Worksheets("Sheet2")
        For n = 1 To 1807
            If n Mod 100 > 0 Then
                r = r + 1
                .Cells(r, "A").Value = n
            End If
        Next n
    End With
End Sub