VBA to keep certain columns and remove all others - excel

Question

As topic says I have a vba code which does the job: remove all columns of sheet "incidents" and keep only the columns with names "Status", "Name" and "Age"
But for some reason, after a few thousand rows, it does not work properly and removes the data/cells of that columns that is keeping , and also works quite slow.
There is any other way to do this? More efective? At least to not remove any cell of that columns which must remain in the sheet.
Thanks in advance (code below).
Sub Cleanup_report2()
Dim currentColumn As Integer
Dim columnHeading As String
For currentColumn = Worksheets("Incidents").UsedRange.Columns.CounT To 1 Step -1
columnHeading = Worksheets("Incidents).UsedRange.Cells(1, currentColumn).Value
'CHECK WHETHER TO KEEP THE COLUMN
Select Case columnHeading
Case "Status", "Name", "Age"
'Do nothing
Case Else
If InStr(1, _
Worksheets("Incidents").UsedRange.Cells(1, currentColumn).Value, _
"DLP", vbBinaryCompare) = 0 Then
Worksheets("Incidents").Columns(currentColumn).Delete
End If
End Select
Next
End Sub

Answer 1

It should be quicker to only do one delete operation:
Sub Cleanup_report2()
Dim currentColumn As Integer
Dim columnHeading As String
Dim rDelete As Excel.Range
With Worksheets("Incidents_data")
For currentColumn = .UsedRange.Columns.Count To 1 Step -1
columnHeading = .UsedRange.Cells(1, currentColumn).Value
'CHECK WHETHER TO KEEP THE COLUMN
Select Case columnHeading
Case "Status", "Name", "Age"
'Do nothing
Case Else
If InStr(1, columnHeading, "DLP", vbBinaryCompare) = 0 Then
If rDelete Is Nothing Then
Set rDelete = .UsedRange.Cells(1, currentColumn)
Else
Set rDelete = Union(rDelete, .UsedRange.Cells(1, currentColumn))
End If
End If
End Select
Next
End With
If Not rDelete Is Nothing Then rDelete.EntireColumn.Delete
End Sub

Answer 2

Here is my anser... hope this helps...
Sub removeColumns()
Dim rng As Range 'store the range you want to delete
Dim c 'total count of columns
Dim i 'an index
Dim j 'another index
Dim headName As String 'The text on the header
Dim Status As String 'This vars is just to get the code cleaner
Dim Name As String
Dim Age As String
Dim sht As Worksheet
Status = "Status"
Name = "Name"
Age = "Age"
Set sht = Sheets("Incidents")
sht.Activate 'all the work in the sheet "Incidents"
c = Range("A1").End(xlToRight).Column
'From A1 to the left at the end, and then store the number
'of the column, that is, the last column
j = 0 'initialize the var
For i = 1 To c 'all the numbers (heres is the columns) from 1 to c
headName = Cells(1, i).Value
If (headName <> Status) And (headName <> Name) And (headName <> Age) Then
'if the header of the column is differente of any of the options
j = j + 1 ' ini the counter
If j = 1 Then 'if is the first then
Set rng = Columns(i)
Else
Set rng = Union(rng, Columns(i))
End If
End If
Next i
rng.Delete 'then brutally erased from leaf
End Sub