VB to filter words contained in range

[Trevor3007]

HI,

Rather than manually create a filter & select the ones 'I dont need ' is it possible to have VB to do this , using a words contained in another worksheet in the same work book? For example

The data to be filtered is in(Source) a2:a150, I want the 'filter' to filter the words that are NOT in the range (filter) Column A
As I often have to run this , it would be quicker to just add the ones I don't want into (filter) Column A, rather than redo the filter each time.

Hoping this makes sense & thanks to the person(s) who like a challenge.

 

[Trebor76]

Hi Trevor3007,

Try this:

Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet, wsFltr As Worksheet
    Dim rngMyCell As Range
    Dim lngLastRow As Long, lngArrayIndex As Long
    Dim strWordsNotMatching() As String
   
    Application.ScreenUpdating = False
   
    Set wsSrc = ThisWorkbook.Sheets("Source")
    Set wsFltr = ThisWorkbook.Sheets("filter")
   
    On Error Resume Next
        wsSrc.ShowAllData
        wsFltr.ShowAllData
    On Error GoTo 0
   
    lngLastRow = wsSrc.Cells(Rows.Count, "A").End(xlUp).Row
   
    For Each rngMyCell In wsSrc.Range("A2:A" & lngLastRow)
        If Application.WorksheetFunction.CountIf(wsFltr.Range("A:A"), CStr(rngMyCell)) = 0 Then
            If lngArrayIndex = 0 Then
                lngArrayIndex = lngArrayIndex + 1
                ReDim Preserve strWordsNotMatching(1 To lngArrayIndex)
                strWordsNotMatching(lngArrayIndex) = CStr(rngMyCell)
            Else
                If IsNumeric(Application.Match(CStr(rngMyCell), strWordsNotMatching, 0)) = False Then 'No need to load duplicates into array
                    lngArrayIndex = lngArrayIndex + 1
                    ReDim Preserve strWordsNotMatching(1 To lngArrayIndex)
                    strWordsNotMatching(lngArrayIndex) = CStr(rngMyCell)
                End If
            End If
        End If
    Next rngMyCell
   
    wsSrc.Range("$A$1:$A$" & lngLastRow).AutoFilter Field:=1, Criteria1:=Array(strWordsNotMatching), Operator:=xlFilterValues
   
    Application.ScreenUpdating = True
   
End Sub

Regards,

Robert

 

[Peter_SSs]

I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

 

[Trevor3007]

Hi Trevor3007,

Try this:

Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet, wsFltr As Worksheet
    Dim rngMyCell As Range
    Dim lngLastRow As Long, lngArrayIndex As Long
    Dim strWordsNotMatching() As String
  
    Application.ScreenUpdating = False
  
    Set wsSrc = ThisWorkbook.Sheets("Source")
    Set wsFltr = ThisWorkbook.Sheets("filter")
  
    On Error Resume Next
        wsSrc.ShowAllData
        wsFltr.ShowAllData
    On Error GoTo 0
  
    lngLastRow = wsSrc.Cells(Rows.Count, "A").End(xlUp).Row
  
    For Each rngMyCell In wsSrc.Range("A2:A" & lngLastRow)
        If Application.WorksheetFunction.CountIf(wsFltr.Range("A:A"), CStr(rngMyCell)) = 0 Then
            If lngArrayIndex = 0 Then
                lngArrayIndex = lngArrayIndex + 1
                ReDim Preserve strWordsNotMatching(1 To lngArrayIndex)
                strWordsNotMatching(lngArrayIndex) = CStr(rngMyCell)
            Else
                If IsNumeric(Application.Match(CStr(rngMyCell), strWordsNotMatching, 0)) = False Then 'No need to load duplicates into array
                    lngArrayIndex = lngArrayIndex + 1
                    ReDim Preserve strWordsNotMatching(1 To lngArrayIndex)
                    strWordsNotMatching(lngArrayIndex) = CStr(rngMyCell)
                End If
            End If
        End If
    Next rngMyCell
  
    wsSrc.Range("$A$1:$A$" & lngLastRow).AutoFilter Field:=1, Criteria1:=Array(strWordsNotMatching), Operator:=xlFilterValues
  
    Application.ScreenUpdating = True
  
End Sub

Regards,

Robert

you sir are a genius.....fantastc. works a treat. You have saved me a whole lot of time.

have a good weekend, a fabulous xmas & a fantastic 2022 too..ho ho ho

 

[Trevor3007]

Hi Trevor3007,

Try this:

Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet, wsFltr As Worksheet
    Dim rngMyCell As Range
    Dim lngLastRow As Long, lngArrayIndex As Long
    Dim strWordsNotMatching() As String
  
    Application.ScreenUpdating = False
  
    Set wsSrc = ThisWorkbook.Sheets("Source")
    Set wsFltr = ThisWorkbook.Sheets("filter")
  
    On Error Resume Next
        wsSrc.ShowAllData
        wsFltr.ShowAllData
    On Error GoTo 0
  
    lngLastRow = wsSrc.Cells(Rows.Count, "A").End(xlUp).Row
  
    For Each rngMyCell In wsSrc.Range("A2:A" & lngLastRow)
        If Application.WorksheetFunction.CountIf(wsFltr.Range("A:A"), CStr(rngMyCell)) = 0 Then
            If lngArrayIndex = 0 Then
                lngArrayIndex = lngArrayIndex + 1
                ReDim Preserve strWordsNotMatching(1 To lngArrayIndex)
                strWordsNotMatching(lngArrayIndex) = CStr(rngMyCell)
            Else
                If IsNumeric(Application.Match(CStr(rngMyCell), strWordsNotMatching, 0)) = False Then 'No need to load duplicates into array
                    lngArrayIndex = lngArrayIndex + 1
                    ReDim Preserve strWordsNotMatching(1 To lngArrayIndex)
                    strWordsNotMatching(lngArrayIndex) = CStr(rngMyCell)
                End If
            End If
        End If
    Next rngMyCell
  
    wsSrc.Range("$A$1:$A$" & lngLastRow).AutoFilter Field:=1, Criteria1:=Array(strWordsNotMatching), Operator:=xlFilterValues
  
    Application.ScreenUpdating = True
  
End Sub

Regards,

Robert

hi Robert,

sorry , my error.. can you include a 'a-z' sort pinro your code (this word be after the filter has been applied)lease?

 

[JEC]

Try this for the complete code

You only have to change the source and filter ranges

Sub jec()
 Set ar2 = Range("C1", Range("C" & Rows.Count).End(xlUp))           'Source range
 Set ar = Range("A2", Range("A" & Rows.Count).End(xlUp))            'filter range
 Set dict = CreateObject("scripting.dictionary")
 
 For i = 2 To ar2.Rows.Count
    If Application.CountIf(ar, ar2(i, 1)) = 0 Then c00 = dict(ar2(i, 1))
 Next
 
 ar2.AutoFilter 1, dict.keys, 7
 ar2.Sort ar2(1, 1), 1, , , , , , xlYes
End Sub

 

[Trebor76]

Hi Trevor3007,

Here is my macro reworked to enable sorting:

Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet, wsFltr As Worksheet
    Dim rngMyCell As Range
    Dim lngLastRow As Long, lngArrayIndex As Long
    Dim strWordsNotMatching() As String
 
    Application.ScreenUpdating = False
 
    Set wsSrc = ThisWorkbook.Sheets("Source")
    Set wsFltr = ThisWorkbook.Sheets("filter")
 
    On Error Resume Next
        wsSrc.ShowAllData
        wsFltr.ShowAllData
    On Error GoTo 0
 
    lngLastRow = wsSrc.Cells(Rows.Count, "A").End(xlUp).Row
 
    For Each rngMyCell In wsSrc.Range("A2:A" & lngLastRow)
        If Application.WorksheetFunction.CountIf(wsFltr.Range("A:A"), CStr(rngMyCell)) = 0 Then
            If lngArrayIndex = 0 Then
                lngArrayIndex = lngArrayIndex + 1
                ReDim Preserve strWordsNotMatching(1 To lngArrayIndex)
                strWordsNotMatching(lngArrayIndex) = CStr(rngMyCell)
            Else
                If IsNumeric(Application.Match(CStr(rngMyCell), strWordsNotMatching, 0)) = False Then 'No need to load duplicates into array
                    lngArrayIndex = lngArrayIndex + 1
                    ReDim Preserve strWordsNotMatching(1 To lngArrayIndex)
                    strWordsNotMatching(lngArrayIndex) = CStr(rngMyCell)
                End If
            End If
        End If
    Next rngMyCell
 
    wsSrc.Range("$A$1:$A$" & lngLastRow).AutoFilter Field:=1, Criteria1:=Array(strWordsNotMatching), Operator:=xlFilterValues
    With wsSrc.AutoFilter.Sort
        .SortFields.Clear
        .SortFields.Add Order:=xlAscending, SortOn:=xlSortOnValues, Key:=wsSrc.Range("$A$1:$A$" & lngLastRow)
        .Apply
    End With
 
    Application.ScreenUpdating = True
 
End Sub

While here is JEC's as I always use Option Explicit and his/hers did not declare any variables along with some other tweaks I made:

Option Explicit
Sub jec()

    Dim wsSrc As Worksheet, wsFltr As Worksheet
    Dim rngSrc As Range, rngFltr As Range, rngMyCell As Range
    Dim objDict As Object
    Dim c00 As String
  
    Application.ScreenUpdating = False
 
    Set wsSrc = ThisWorkbook.Sheets("Source")
    Set wsFltr = ThisWorkbook.Sheets("filter")
 
    On Error Resume Next
        wsSrc.ShowAllData
        wsFltr.ShowAllData
    On Error GoTo 0
  
    Set rngSrc = wsSrc.Range("A2", wsSrc.Range("A" & Rows.Count).End(xlUp)) 'Source range
    Set rngFltr = wsFltr.Range("A1", wsFltr.Range("A" & Rows.Count).End(xlUp)) 'filter range
    Set objDict = CreateObject("Scripting.Dictionary")
  
    For Each rngMyCell In rngSrc
       If Application.CountIf(rngFltr, rngMyCell) = 0 Then c00 = objDict(rngMyCell)
    Next rngMyCell
  
    rngSrc.AutoFilter 1, objDict.keys, 7
    rngSrc.Sort rngSrc(1, "A"), 1, , , , , , xlYes
  
End Sub

have a good weekend, a fabulous xmas & a fantastic 2022 too..ho ho ho

Thank you Same to you and yours ?

 

[Peter_SSs]

If you are just interested in the list of words that are not in the 'filter' list then perhaps you don't need to actually filter or use vba?
This would automatically give you the list any time changes were made in either sheet without re-running the macro.

Trevor3007.xlsm
	A
1	List
2	dog
3	mouse
4	bird
5
filter

Trevor3007.xlsm
	A	B	C
1	Words		Result
2	cat		cat
3	dog		cow
4	horse		horse
5	mouse		rat
6	cow
7	rat
8	bird
9
Source

Cell Formulas
Range	Formula
C2:C5	C2	=SORT(FILTER(A2:A150,(A2:A150<>"")*ISNA(MATCH(A2:A150,filter!A:A,0)),""))
Dynamic array formulas.

 

[Trebor76]

Hi Peter,

Although only applicable for Excel 16.0 and on, very nifty formula How would you write it to list the matches? I thought this may do it but the list was the same:

=SORT(FILTER(A2:A150,(A2:A150<>"")*ISERROR(MATCH(A2:A150,filter!A:A,0)=FALSE),""))

In case someone reading this may want it, I have included a boolean variable to the following to allow for switching between matches and non-matches.

Option Explicit
Sub jec()

    Dim wsSrc As Worksheet, wsFltr As Worksheet
    Dim rngSrc As Range, rngFltr As Range, rngMyCell As Range
    Dim objDict As Object
    Dim c00 As String
    Dim blnMatch As Boolean
    
    Application.ScreenUpdating = False
   
    Set wsSrc = ThisWorkbook.Sheets("Source")
    Set wsFltr = ThisWorkbook.Sheets("filter")
   
    On Error Resume Next
        wsSrc.ShowAllData
        wsFltr.ShowAllData
    On Error GoTo 0
    
    Set rngSrc = wsSrc.Range("A2", wsSrc.Range("A" & Rows.Count).End(xlUp)) 'Source range
    Set rngFltr = wsFltr.Range("A1", wsFltr.Range("A" & Rows.Count).End(xlUp)) 'filter range
    Set objDict = CreateObject("Scripting.Dictionary")
    blnMatch = True 'False for non-matching entries, True for matching
    
    For Each rngMyCell In rngSrc
        If blnMatch = False Then
            If Application.CountIf(rngFltr, rngMyCell) = 0 Then c00 = objDict(rngMyCell)
        Else
            If Application.CountIf(rngFltr, rngMyCell) >= 1 Then c00 = objDict(rngMyCell)
        End If
    Next rngMyCell
    
    rngSrc.AutoFilter 1, objDict.keys, 7
    rngSrc.Sort rngSrc(1, "A"), 1, , , , , , xlYes
    
End Sub

Thanks,

Robert

 

[Peter_SSs]

How would you write it to list the matches?

=SORT(FILTER(A2:A150,ISNUMBER(MATCH(A2:A150,filter!A:A,0)),""))