Option Base 1
Public sArray()
Sub qq()
Dim arr()
cStart = ActiveCell.Column
rEnd& = ActiveSheet.UsedRange.Rows.Count
cEnd& = ActiveSheet.UsedRange.Columns.Count
arr = Range(Cells(2, 1), Cells(rEnd, cEnd)).Value
Call iFilter(11, arr)
Cells(2, 1).Resize(UBound(sArray, 1), UBound(sArray, 2)) = sArray
End Sub
Sub iFilter(ByVal n As Byte, ByRef mass())
Dim indcol, sp%, pp$, a&, b%, mm, arr(), arr0(), x&, c%, cc&
    Set indcol = CreateObject("Scripting.Dictionary")
    ReDim sArray(1 To UBound(mass, 1), 1 To UBound(mass, 2))
    sp = 0: pp = Chr(0) & Chr(0) & Chr(0) & Chr(0): x = 1
    If n > UBound(mass, 2) Then n = UBound(mass, 2)
    If n < 1 Then n = 1
    With indcol
      For a = 1 To UBound(mass, 1)
         If mass(a, n) = "" Then mass(a, n) = pp: sp = sp + 1
         If Not .exists(mass(a, n)) Then
           ReDim arr(1 To 2): arr(1) = x: arr(2) = a: .Add mass(a, n), arr: x = x + 1
           For b = 1 To UBound(mass, 2): sArray(.Count, b) = mass(a, b): Next b
         Else
           arr = .Item(mass(a, n))
           For b = 1 To UBound(mass, 2)
             If mass(a, b) <> mass(arr(2), b) Then
               If InStr(sArray(arr(1), b), mass(a, b)) = 0 Then 
                 sArray(arr(1), b) = sArray(arr(1), b) & ", " & mass(a, b)
             End If:End If
           Next b
         End If
      Next a
      End With
      If sp = 0 Then Exit Sub
      For a = 1 To UBound(sArray, 1)
        If sArray(a, n) = pp Then sArray(a, n) = "": mass(a, n) = ""
      Next a
    
End Sub