Well, if you don’t like that one blank line at the beginning of the list, you can use a function like this:
Option Explicit
Function SortWithFilter(aData As Variant, sFilter As String) As Variant
Dim i As Long, j As Long
Dim aRes As Variant
aRes = Array()
For i = LBound(aData) To UBound(aData)
For j = LBound(aData,2) To UBound(aData,2)
If InStr(aData(i,j), sFilter) > 0 Then AddOrInsert(aRes, aData(i,j))
Next j
Next i
If UBound(aRes) <= LBound(aRes) Then
SortWithFilter = aData
Else
SortWithFilter = aRes
EndIf
End Function
Sub AddOrInsert(aData As Variant, key As Variant)
Dim l&, r&, m&, N&, i&
l = LBound(aData)
r = UBound(aData) + 1
N = r
While (l < r)
m = l + Int((r - l) / 2)
If aData(m) < key Then l = m + 1 Else r = m
Wend
If r = N Then
ReDim Preserve aData(0 To N)
aData(N) = key
ElseIf aData(r) = key Then
' Already in this array - nothing to do '
Else
ReDim Preserve aData(0 To N)
For i = N - 1 To r Step -1
aData(i + 1) = aData(i)
Next i
aData(r) = key
End If
End Sub
By the way, you do not need auxiliary ranges and intermediate calculations - insert the formula directly into Validity - Criteria - Source
Update You can use this version of the main function
Function SortWithFilter(aData As Variant, sFilter As String) As Variant
Dim i As Long, j As Long
Dim aRes As Variant, aFullData As Variant
aRes = Array()
aFullData = Array()
For i = LBound(aData) To UBound(aData)
For j = LBound(aData,2) To UBound(aData,2)
If IsEmpty(aData(i,j)) Then
SortWithFilter = aRes
If (UBound(aRes) < LBound(aRes)) Then
SortWithFilter = aFullData
ElseIf ((UBound(aRes) = 0) And (aRes(0)=sFilter)) Then
SortWithFilter = aFullData
EndIf
Exit Function
EndIf
If Trim(aData(i,j))<>"" Then
AddOrInsert(aFullData, aData(i,j))
If InStr(aData(i,j), sFilter) > 0 Then AddOrInsert(aRes, aData(i,j))
EndIf
Next j
Next i
End Function
In this case, you can set once and for all the initial range of any size - the selection list will be formed only for the existing values - SORTWITHFILTER($A$2:$A$1048576;E2)
