Excel VBA: Filter and delete rows based on an array criteria range

April 5, 2024

I have the following code and am struggling to get it to work.

Sub FilterAndRemove()
        
    Dim varDelItem As Variant
    Dim lngRowStart As Long, _
        lngRowLast As Long, _
        lngRowActive As Long
    Dim strMyCol As String
    Dim rngDelRange As Range
    
    varDelItem = Application.Transpose(Worksheets("ELEMENTS").Range("AA2:AA32"))
    lngRowStart = 2
    strMyCol = "A"
    lngRowLast = Cells(Rows.Count, strMyCol).End(xlUp).Row
    
    Application.ScreenUpdating = False
        
    For lngRowActive = lngRowStart To lngRowLast
        If Cells(lngRowActive, strMyCol) <> varDelItem Then
            If rngDelRange Is Nothing Then
                Set rngDelRange = Cells(lngRowActive, strMyCol)
            Else
                Set rngDelRange = Union(rngDelRange, Cells(lngRowActive, strMyCol))
            End If
        End If
    Next lngRowActive
        
    If Not rngDelRange Is Nothing Then
        rngDelRange.EntireRow.Delete xlShiftUp
    End If
    
    Application.ScreenUpdating = True
        
End Sub

What I am trying to achieve: I have a list of values which will be the conditions. After pasting data onto active sheet and activating the macro, the filter function should find rows not containing the data from the conditions list and remove them.

I can get it to work by specifying only one condition, i.e. Range("AA2"), but I want it to check against the whole range/array. What is wrong with my code? I am getting Type Mistmatch error.

Thanks in advance.

>Solution :

Pls. try this code

Sub comp()
    Dim varDelItem As Variant
    Dim lngRowStart As Long, _
        lngRowLast As Long, _
        lngRowActive As Long
    Dim strMyCol As String
    Dim rngDelRange As Range
    varDelItem = Application.Transpose(Worksheets("ELEMENTS").Range("AA2:AA32"))
    lngRowStart = 2
    strMyCol = "A"
    lngRowLast = Cells(rows.Count, strMyCol).End(xlUp).Row
    
    
    Application.ScreenUpdating = False
        

    For lngRowActive = lngRowStart To lngRowLast
        ident = False     'added
        For Each cell In varDelItem    'added
            If Cells(lngRowActive, strMyCol) = cell Then ident = True: Exit For   'added
        Next cell       'added
        If Not ident Then  'changed
            If rngDelRange Is Nothing Then
                Set rngDelRange = Cells(lngRowActive, strMyCol)
            Else
                Set rngDelRange = Union(rngDelRange, Cells(lngRowActive, strMyCol))
            End If
        End If
    Next lngRowActive

   If Not rngDelRange Is Nothing Then
        rngDelRange.EntireRow.Delete xlShiftUp
    End If
    
    Application.ScreenUpdating = True
        
End Sub

The ident variable is True if a match is found in the conditions range. Then not execute the adding to the deletion range.