Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
' Work
'==================================================================================================
Function PRDX_StrToArrL(sIn$, sep$, aL_Out() As Long) As Boolean
Dim x, arr, n&

    arr = Split(sIn, sep)
    ReDim aL_Out(UBound(arr) + 1)

    For Each x In arr
        n = n + 1: aL_Out(n) = x
    Next x

PRDX_StrToArrL = True
End Function
'==================================================================================================
' ' Faster than Dictionary
Function PRDX_ArrL_ChangeIndVal(aIn() As Long, aOut() As Long, Optional SetVal&) As Boolean
Dim UBnd&, r&, i&, n&

UBnd = 2 * UBound(aIn)
ReDim aOut(UBnd)

For r = 1 To UBound(aIn)
    i = aIn(r):     If (UBnd < i) Then UBnd = 2 * i: ReDim Preserve aOut(UBnd)
    If (SetVal = 0) Then aOut(i) = r Else aOut(i) = SetVal
    If (n < i) Then n = i
Next r

ReDim Preserve aOut(n)
PRDX_ArrL_ChangeIndVal = True
End Function
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_ArrL_ChangeIndVal()
Dim a&(), b&(), n&

    PRDX_StrToArrL "5/3/2", "/", a

    For n = 1 To UBound(a)
        Debug.Print "a(" & n & ") = " & a(n)    ' a(1) = 5; a(2) = 3; a(3) = 2
    Next n

    Debug.Print String$(20, "-")
    PRDX_ArrL_ChangeIndVal a, b

    For n = 1 To UBound(b)
        Debug.Print "b(" & n & ") = " & b(n)    ' b(1) = 0; b(2) = 3; b(3) = 2; b(4) = 0; b(5) = 1
    Next n

    Debug.Print String$(20, "-")
    PRDX_ArrL_ChangeIndVal a, b, 100

    For n = 1 To UBound(b)
        Debug.Print "b(" & n & ") = " & b(n)    ' b(1) = 0; b(2) = 100; b(3) = 100; b(4) = 0; b(5) = 100
    Next n
End Sub
'==================================================================================================
' Main
'==================================================================================================
Private Function FillDic(a2D, nCol&, dicOut As Dictionary) As Boolean
Dim x, arr, aJ$(), aRows&()
Dim s$, r&, n&, nn&
Const sep$ = " "

    Set dicOut = New Dictionary
    ReDim aJ(UBound(a2D, 1), 2) ' Key, Join

    For r = 1 To UBound(a2D, 1)
        s = a2D(r, nCol)

        If dicOut.Exists(s) Then
            nn = dicOut(s): aJ(nn, 2) = aJ(nn, 2) & sep & r ' Slow
        Else
            n = n + 1: dicOut.Add s, n: aJ(n, 1) = s: aJ(n, 2) = r
        End If
    Next r

    dicOut.RemoveAll
    
    For r = 1 To n  ' Convert "1 2 3" to Array(1, 2, 3) As Long
        If Not PRDX_StrToArrL(aJ(r, 2), sep, aRows) Then Stop: End
        dicOut.Add aJ(r, 1), aRows
    Next r

FillDic = True
End Function
'==================================================================================================
Function PRDX_Tbl_ReCalc(a2D_Tbl, a1D_ColFilt, aDic_Out() As Dictionary) As Boolean
Dim x, n&

ReDim aDic_Out(UBound(a1D_ColFilt))

For Each x In a1D_ColFilt
    n = n + 1: If Not FillDic(a2D_Tbl, --x, aDic_Out(n)) Then Stop: End
Next x

PRDX_Tbl_ReCalc = True
End Function
'==================================================================================================
'==================================================================================================
' Filter
'==================================================================================================
Private Function RowsOfDic(a1D_ColFilt, a1D_ColVal, a1D_ColIV, aDic() As Dictionary, aArrRows_Out()) As Boolean
Dim s$, n&, i&, p&

ReDim aArrRows_Out(UBound(a1D_ColIV))

For n = 1 To UBound(a1D_ColFilt)
    i = a1D_ColIV(a1D_ColFilt(n))   ' Index of Col# a1D_ColFilt(n) in aDic()

    If (i <> 0) Then
        s = a1D_ColVal(n)
        If aDic(i).Exists(s) Then p = p + 1: aArrRows_Out(p) = aDic(i)(s)
    End If
Next n

If (p = 0) Then Exit Function
ReDim Preserve aArrRows_Out(p): RowsOfDic = True
End Function
'==================================================================================================
Private Function RowsInsersect(aArrRows(), aRows_Out() As Long) As Boolean
Dim x, aVI&()
Dim iMin&, UBnd&, n&, i&

If (UBound(aArrRows) = 1) Then aRows_Out = aArrRows(1): GoTo fn
iMin = UBound(aArrRows(1)): i = 1

For n = 2 To UBound(aArrRows)       ' Find Minimal Array
    UBnd = UBound(aArrRows(n))
    If (iMin > UBnd) Then iMin = UBnd: i = n
Next n

aRows_Out = aArrRows(i)             ' Set Minimal Array
If Not PRDX_ArrL_ChangeIndVal(aRows_Out, aVI, 1) Then Stop: End ' Set Array Like "Dictionary"
ReDim aRows_Out(UBound(aRows_Out))

On Error Resume Next
    For n = 1 To UBound(aArrRows)   ' Filter aRows_Out
        If (n <> i) Then
            For Each x In aArrRows(n)
                aVI(x) = aVI(x) + 1
            Next x
        End If
    Next n
On Error GoTo 0

n = 0: i = 0: UBnd = UBound(aArrRows)

For i = 1 To UBound(aVI)
    If (aVI(i) = UBnd) Then n = n + 1: aRows_Out(n) = i
Next i

If (n = 0) Then Exit Function
ReDim Preserve aRows_Out(n)

fn: RowsInsersect = True
End Function
'==================================================================================================
Function PRDX_Tbl_Filter_GetRows(a1D_ColFilt, a1D_ColVal, a1D_ColIV, aDic() As Dictionary, aRows_Out() As Long) As Boolean
Dim aArrR()
    If Not RowsOfDic(a1D_ColFilt, a1D_ColVal, a1D_ColIV, aDic, aArrR) Then Exit Function
    PRDX_Tbl_Filter_GetRows = RowsInsersect(aArrR, aRows_Out)
End Function
'==================================================================================================
Function PRDX_Tbl_Filter_Arr2D(a2D_In, a2D_Out, aRows() As Long) As Boolean
Dim r&, rr&, c&

    ReDim a2D_Out(UBound(aRows), UBound(a2D_In, 2))

    For r = 1 To UBound(aRows)
        rr = aRows(r)

        For c = 1 To UBound(a2D_In, 2)
            a2D_Out(r, c) = a2D_In(rr, c)
        Next c
    Next r

PRDX_Tbl_Filter_Arr2D = True
End Function
'==================================================================================================
'==================================================================================================
'==================================================================================================

Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Public vp_aDic() As Dictionary, vp_aCol&(), vp_aColIV&()
'==================================================================================================
Function PRDX_Ex_TblUpdate(Optional Force As Boolean) As Boolean
Dim a
Static st&

    If (st = 1) Then If Force Then st = 0 Else GoTo fn

    If Not PRDX_StrToArrL("2/3/4/5", "/", vp_aCol) Then Stop: End
    If Not PRDX_ArrL_ChangeIndVal(vp_aCol, vp_aColIV) Then Stop: End

    a = shTbl.ListObjects(1).DataBodyRange.Value2
    If Not PRDX_Tbl_ReCalc(a, vp_aCol, vp_aDic) Then Stop: End
    st = 1
fn: PRDX_Ex_TblUpdate = True
End Function
'==================================================================================================
'==================================================================================================
Private Function GetFilter(aCol_Out() As Long, aVal_Out() As String) As Boolean
Dim arr, c&, n&

arr = shUniq.Range("A2:D2").Value2
ReDim aCol_Out(UBound(arr, 2)): ReDim aVal_Out(UBound(aCol_Out))

For c = 1 To UBound(arr, 2)
    If Not IsEmpty(arr(1, c)) Then n = n + 1: aCol_Out(n) = c + 1: aVal_Out(n) = arr(1, c)
Next c

If (n = 0) Then Exit Function

ReDim Preserve aCol_Out(n), aVal_Out(n)
GetFilter = True
End Function
'--------------------------------------------------------------------------------------------------
Function PRDX_Ex_TblFilter() As Boolean
Dim cl As Range
Dim aTbl, aFlt(), aCol&(), aRows&(), aVal$()

    If Not GetFilter(aCol, aVal) Then Exit Function
    If Not PRDX_Ex_TblUpdate() Then Stop: End

    Set cl = shUniq.Range("I5")
    cl.Resize(shUniq.UsedRange.Rows.Count, 5).ClearContents
    
    If Not PRDX_Tbl_Filter_GetRows(aCol, aVal, vp_aColIV, vp_aDic, aRows) Then Exit Function
    
    aTbl = shTbl.ListObjects(1).DataBodyRange.Value2
    If Not PRDX_Tbl_Filter_Arr2D(aTbl, aFlt, aRows) Then Stop: End
    
    cl.Resize(UBound(aFlt, 1), UBound(aFlt, 2)).Value2 = aFlt

PRDX_Ex_TblFilter = True
End Function
'==================================================================================================
'==================================================================================================
'==================================================================================================