VBA extract unique values based on criteria - excel

Question

I want to get a list of distinct value based on a criteria, example : I have a list of stores, and i want to get only distinct value based on retailer criteria "BOULANGER".
Sub distinctValues()
Dim LastRow As Long
Dim Crit1 As String
LastRow = Sheets("SOURCE").Cells(Rows.Count, "B").End(xlUp).Row
Sheets("SOURCE").Range("B1:B" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("TEST").Range("E2"), CopyToRange:=Sheets("TEST").Range("A12"), Unique:=True
End Sub

Answer 1

I suspect your Criteria Range is not properly set up and/or named on your worksheet.
In the .AdvancedFilter, you have:
Range(Crit1)
which, according to your code, will be interpreted as:
Range("BOULANGER")
This presumes you have a Named Range somewhere on your Test Worksheet that is named BOULANGER and refers to two cells in a column, the first of which contains Store and the second contains BOULANGER
If you have that set up properly, then your code works.
Note that in your screen shot showing the criteria, the first cell contains Criteria and not Store. So even if you had the defined range setup to encompass those two cells, it would not work since the first row has to have an identical name to the column being filtered.

Answer 2

This should accomplish what you are trying to do; see comments in the code.
Sub ListUniqueValues()
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Sheet1") 'change as needed
Set ws2 = ThisWorkbook.Sheets("Sheet2") 'change as needed
ws1.Range("B1", ws1.Cells(Rows.Count, "B").End(xlUp)).Copy ws2.Range("C1") 'copy the full range from sheet1
ws2.Range("C1", ws2.Cells(Rows.Count, "C").End(xlUp)).RemoveDuplicates Columns:=Array(1), Header:=xlNo 'remove duplicates
Dim lRow As Long
lRow = ws2.Cells(Rows.Count, 3).End(xlUp).Row 'set lastrow variable
For i = lRow To 1 Step -1 'Da Loop, from bottom to top
'change the cell address after "Like" to the cell address where you put your store criteria
'the line will delete any store name that is not like your store criteria
'the (& "*") inserts the wildcard after your store criteria you type in your designated cell, e.g. "BOULANGER*"
If Not ws2.Cells(i, 3).Value Like ws2.Cells(1, 1).Value & "*" Then '
ws2.Cells(i, 3).Delete 'delete the cells that do not match your store criteria
End If
Next i
End Sub

Answer 3

If you are trying to get a unique range that contains a keyword, something like this should work.
Option Explicit
Private Sub OutputUniqueRange(SearchRange As Range, Keyword As String, OutputRange As Range)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim cell As Range
For Each cell In SearchRange
With cell
If InStr(1, .Value2, Keyword, vbTextCompare) > 0 And Not dict.exists(.Value2) Then dict.Add .Value2, .Value2
End With
Next
If dict.Count = 0 Then Exit Sub
OutputRange.Range(OutputRange.Cells(1, 1).Address).Resize(dict.Count, 1) = Application.Transpose(dict.items())
End Sub
Public Sub TestSub()
Dim SearchRange As Range
Dim Keyword As String
Dim OutputRange As Range
Keyword = "Boulanger"
Set SearchRange = ThisWorkbook.Sheets("Sheet1").Range("A2:A34")
Set OutputRange = ThisWorkbook.Sheets("Sheet1").Range("B2")
OutputUniqueRange SearchRange, Keyword, OutputRange
End Sub