Delete columns/rows when doesn't contain values from varLists

Question

I am new to VBA... I am trying delete all columns from Sheet1:"Template" ROW1/headers file that doesn't match any of the cell values on varList:"ColumnsList" (that is in Sheet3).

How do I select the headers or how do I select the row 1 range to search into?

Also, I have a runtime error 5 in this line: invalid procedure call or argument.

If Intersect(rng.Cells(1, i).EntireColumn, rngF) Is Nothing Then

Any kind soul that help me with that please?

Also, I need to do the same but with rows from Sheet1:"Template". I need to delete any row that doesn't CONTAIN any cell value from varList:"Agents" (that is in Sheet2).

Could you please help me out?

Maaaany thanks in advance!!!

Option Compare Text
Sub ModifyTICBData()

Dim varList As Variant
    Dim lngarrCounter As Long
    Dim rngFound As Range, rngToDelete As Range
    Dim strFirstAddress As String

    'Application.ScreenUpdating = False

    varList = VBA.Array("ColumnsList") 'I want to keep columns with these values, NOT DELETE THEM

    For lngarrCounter = LBound(varList) To UBound(varList)

        With Sheets("Template").UsedRange
            Set rngFound = .Find( _
                                What:=varList(lngarrCounter), _
                                Lookat:=xlWhole, _
                                SearchOrder:=xlByColumns, _
                                SearchDirection:=xlNext, _
                                MatchCase:=True)

            If Not rngFound Is Nothing Then
                strFirstAddress = rngFound.Address

                If rngToDelete Is Nothing Then
                    Set rngToDelete = rngFound
                Else
                    If Application.Intersect(rngToDelete, rngFound.EntireColumn) Is Nothing Then
                        Set rngToDelete = Application.Union(rngToDelete, rngFound)
                    End If
                End If

                Set rngFound = .FindNext(After:=rngFound)

                Do Until rngFound.Address = strFirstAddress
                    If Application.Intersect(rngToDelete, rngFound.EntireColumn) Is Nothing Then
                        Set rngToDelete = Application.Union(rngToDelete, rngFound)
                    End If
                    Set rngFound = .FindNext(After:=rngFound)
                Loop
            End If
        End With
    Next lngarrCounter

    Dim rngDel As Range
Set rngDel = NotIntersectRng(Sheets("Template").UsedRange, rngToDelete)
If Not rngDel Is Nothing Then rngDel.EntireColumn.delete

    'Application.ScreenUpdating = True
End Sub

Private Function NotIntersectRng(rng As Range, rngF As Range) As Range
  Dim rngNI As Range, i As Long, j As Long
  For i = 1 To rng.Columns.Count
    **If Intersect(rng.Cells(1, i).EntireColumn, rngF) Is Nothing Then**
        If rngNI Is Nothing Then
            Set rngNI = rng.Cells(1, i)
        Else
            Set rngNI = Union(rngNI, rng.Cells(1, i))
        End If
    End If
  Next i
  If Not rngNI Is Nothing Then Set NotIntersectRng = rngNI
End Function

Answer 1

Delete Columns, Then Rows

Description

• Deletes columns that in the first row do not contain values from a list. Then deletes rows that in the first column do not contain values from another list.

The Flow

• Writes the values from range A2 to the last cell in Sheet3 to the Cols Array.
• Writes the values from range A2 to the last cell in Sheet2 to the Agents Array.
• Using CurrentRegion defines the DataSet Range (rng).
• Loops through the cells (cel) in first row starting from the 2nd column and compares their values to the values from the Cols Array. If not found adds the cells to the Delete Range(rngDel).
• Finally deletes the entire columns of the cells 'collected'.
• Loops through the cells (cel) in first column starting from the 2nd row and compares their values to the values from the Agents Array. If not found adds the cells to the Delete Range(rngDel).
• Finally deletes the entire rows of the cells 'collected'.
• Informs the user of success or no action.

The Code

Option Explicit

Sub ModifyTICBData()

    ' Define workbook ('wb').
    Dim wb As Workbook
    Set wb = ThisWorkbook
    
    ' Define Columns List ('Cols').
    Dim ws As Worksheet
    Set ws = wb.Worksheets("Sheet3")
    Dim rng As Range
    Set rng = ws.Cells(ws.Rows.Count, "A").End(xlUp)
    Dim Cols As Variant
    Cols = ws.Range("A2", rng).Value
    
    ' Define Agents List ('Agents').
    Set ws = wb.Worksheets("Sheet2")
    Set rng = ws.Cells(ws.Rows.Count, "A").End(xlUp)
    Dim Agents As Variant
    Agents = ws.Range("A2", rng).Value
    
    ' Define DataSet Range ('rng').
    Set rng = wb.Worksheets("Template").Range("A1").CurrentRegion
    
    Application.ScreenUpdating = False
    
    ' Define Delete Range ('rngDel') for Columns.
    Dim rngDel As Range
    Dim cel As Range
    For Each cel In rng.Rows(1).Resize(, rng.Columns.Count - 1) _
                               .Offset(, 1).Cells
        If IsError(Application.Match(cel.Value, Cols, 0)) Then
            collectCells rngDel, cel
        End If
    Next cel
    ' Delete Columns.
    Dim AlreadyDeleted As Boolean
    If Not rngDel Is Nothing Then
        rngDel.EntireColumn.Delete
    Else
        AlreadyDeleted = True
    End If
    
    ' Define Delete Range ('rngDel') for Agents.
    Set rngDel = Nothing
    For Each cel In rng.Columns("A").Resize(rng.Rows.Count - 1) _
                                    .Offset(1).Cells
        If IsError(Application.Match(cel.Value, Agents, 0)) Then
            collectCells rngDel, cel
        End If
    Next cel
    ' Delete Agents (Rows).
    If Not rngDel Is Nothing Then
        rngDel.EntireRow.Delete
        AlreadyDeleted = False
    End If
    
    Application.ScreenUpdating = True

    ' Inform user
    If Not AlreadyDeleted Then
        MsgBox "The data was succesfully deleted.", vbInformation, "Success"
    Else
        MsgBox "The data had already been deleted.", vbExclamation, "No Action"
    End If
    
End Sub

Sub collectCells(ByRef CollectRange As Range, CollectCell As Range)
    If Not CollectCell Is Nothing Then
        If Not CollectRange Is Nothing Then
            Set CollectRange = Union(CollectRange, CollectCell)
        Else
            Set CollectRange = CollectCell
        End If
    End If
End Sub