VBA to Delete Excel Columns from a List - excel

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