How can I delete all columns that do not have specified words in header?

Question

I'm trying to clean up my worksheet by only displaying columns that are necessary. However, since I do not know what additional columns may be on the sheet, I am trying to delete all those that do not have some specified words in their headers. For example, I need to display 'First Name', 'Last Name', and 'Phone Number', and delete all other columns.

I am currently using the code below to do that. The problem is this - sometimes, in the data source, the column name for 'Phone Number' is given as 'Cell Phone'. In this case, I would like to match the word 'phone' to the column header and keep it, regardless of whether it says 'Phone Number' or 'Cell Phone'. Right now, if the header does not say 'Phone Number', it gets deleted.

Mylist = Array("First Name", "Last Name", "Phone Number") 

LC = Cells(1, Columns.Count).End(xlToLeft).Column

For mycol = LC To 1 Step -1
    x = ""
    On Error Resume Next
    x = WorksheetFunction.Match(Cells(1, mycol), Mylist, 0)
    If Not IsNumeric(x) Then Columns(mycol).EntireColumn.Delete
Next mycol

How can I match the column headers to words contained and not exact names?

Answer 1

Since the objective is to obtain partial matches it's suggested to use the Range.Find method (Excel) instead of WorksheetFunction.Match.

The Array list should have only the keywords we need to find, i.e. Phone instead of Phone Number, etc.

This solution uses the Range.Find method to create a Target range with all the fields needed, then deletes all the columns that are not in the Target range.

Sub Range_Delete_Unwanted_Fields()
Dim aList As Variant
aList = Array("Missing1", "Name", "Missing2", "Phone")
Dim ws As Worksheet
Dim rSrc As Range, rTrg As Range, rCll As Range
Dim vItem As Variant, sAdrs As String

    Set ws = ThisWorkbook.Worksheets("DATA")

    Rem Set Source Range (Header)
    With ws
        Set rSrc = .Cells(1).Resize(1, .Cells(1, .Columns.Count).End(xlToLeft).Column)
        rSrc.EntireColumn.Hidden = False
    End With

    Rem Set Target Range (Fields in Array List)
    For Each vItem In aList
        With rSrc

            Rem Clear 1st Found Cell Address
            sAdrs = vbNullString

            Rem Set 1st Found Cell
            Set rCll = .Cells.Find( _
                What:=vItem, After:=.Cells(.Cells.Count), _
                LookIn:=xlFormulas, LookAt:=xlPart, _
                SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)

            Rem Validate 1st Found Cell
            If Not (rCll Is Nothing) Then

                Rem Get 1st Found Cell Address
                sAdrs = rCll.Address

                Rem Add Found Cell To Target Range
                If rTrg Is Nothing Then
                    Set rTrg = rCll
                Else
                    Set rTrg = Union(rTrg, rCll)
                End If

                Rem Find Other Cells
                Do
                    Set rCll = .Cells.FindNext(After:=rCll)

                    Rem Validate Next Cell against 1st Cell
                    If rCll.Address = sAdrs Then Exit Do

                    Rem Add Next Cell To Target Range
                    Set rTrg = Union(rTrg, rCll)

                Loop Until rCll.Address = sAdrs

    End If: End With: Next

    Rem Validate Target Range
    If Not rTrg Is Nothing Then
        Rem Delete Columns Not in Target Range Only if Headers were found!
        rTrg.EntireColumn.Hidden = True
        rSrc.SpecialCells(xlCellTypeVisible).EntireColumn.Delete
        rTrg.EntireColumn.Hidden = False
    End If

    Application.Goto ws.Cells(1), 1

    End Sub