Unique Values from multiple columns of Table

A slightly different way

Sub AAA()
    Dim varrData    As Variant
    Dim varrHeader  As Variant
    Dim r As Long, c As Long
    Dim oDic        As Object
    Dim v           As Variant
    Dim i           As Long

    Set oDic = CreateObject("Scripting.Dictionary")

    varrData = Worksheets("Base Sheet").ListObjects(1).DataBodyRange.Value
    varrHeader = Worksheets("Base Sheet").ListObjects(1).HeaderRowRange.Value

    'add teachers (in Keys) and their subjects (in Items) to the Dictionary
    For c = 1 To UBound(varrData, 2)
        For r = 1 To UBound(varrData)
            If Len(varrData(r, c)) > 0 Then
                If oDic.Exists(varrData(r, c)) Then
                    oDic(varrData(r, c)) = oDic(varrData(r, c)) & "|" & varrHeader(1, c)
                Else
                    oDic.Add varrData(r, c), varrHeader(1, c)
                End If
            End If
        Next r
    Next c

    
    With Worksheets("Result Sheet")
        'delete rows with old data (if exists)
        If Len(.Range("C7").Value) > 0 Then
            .Range(.Cells(7, "C"), .Cells(.Rows.Count, "C").End(xlUp)).EntireRow.Delete
        End If
        'insert list of teachers
        .Range("C7").Resize(oDic.Count).Value = Application.Transpose(oDic.Keys())
        'fill the range of 5 columns with "Nil"
        .Range("D7").Resize(oDic.Count, 5).Value = "Nil"

        'fetch the subjects of the following teachers and put them into the range
        For i = 0 To oDic.Count - 1
            v = Split(oDic.Items()(i), "|")
            .Range("D7").Offset(i).Resize(, UBound(v) + 1).Value = v
        Next i

        'insert Sr.No.
        With .Range("B7")
            .Value = 1
            .DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
                        Step:=1, Stop:=oDic.Count, Trend:=False
        End With
    End With

End Sub

Artik