Unique Values from multiple columns of Table

Hello,

As per attached sample file, there are two sheets, sheet 1 is Basic Data and Sheet 2 is Expected Result.
In basic data sheet, Table is given in which header is name of the subject and below it list of teachers is given. One teacher can be seen multiple times at different subjects. As it is sample file, in actual work number of teachers and subject may increase or decrease. Also name of the teacher and subject from basic table may also get replaced. It is because in future teacher or subject may get replace and new teacher and subject may get introduced.

I want to have unique list of teachers in result sheet in given format. Also their name of the subjects will appear next to their name as per given format.

In result sheet, In the blank cell of subject, automatic value 'Nil' will appear.

In Basic data sheet, size of the table will increase or decrease with addition or deletion of the teacher and subject name.

This code will work only in selected areas in result sheet as per given (separate instructions) in the sample file.

Need VBA code for this. I have tried formulas but it is reducing performance/speed of the file.

Thank you for Help.

I was thinking that code will find Name of the Teachers and will arrange them with serial number. There is no any pre-decided Sr. no. with teacher Name. Any teacher name may come to any serial number is acceptable.

It will be more helpful to prepare Columns B:C in result sheet automatically and not manually.

Originally Posted by JohnTopley

Sub Subjects2Teachers()

Dim FoundCell As Range
Dim LastCell As Range
Dim FirstAddr As String, sparm As String
Dim subjects As Range
Dim srange As Range
Dim lr As Long, lc As Long, c As Long, r As Long, n As Long
Dim ws1 As Worksheet, ws2 As Worksheet

Set ws1 = Sheets("Base Sheet")
Set ws2 = Sheets("Result Sheet")

With ws1
    lr = .[a2].CurrentRegion.Rows.Count
    lc = .[a2].CurrentRegion.Columns.Count
    Set srange = .Range("A2:Z" & lr)        ' List of subjects
    Call List_Teachers(lr, lc)              ' Create list of teachers
End With

For c = 1 To lc
    ws2.Cells(1, c + 3) = "Name of the Subject " & c  ' Headers for "Result Sheet"
Next c

With ws2

    For r = 2 To .Cells(Rows.Count, 3).End(xlUp).Row  '' Loop through list of teachers ...
    
        sparm = .Cells(r, 3)   ' Teacher
        
        '******************************************************************
        '  Find all subjects  for this teacher
        '
        
        With srange
            Set LastCell = .Cells(.Cells.Count)
        End With
        
        Set FoundCell = srange.Find(What:=sparm, after:=LastCell, Lookat:=xlWhole)
        
        If Not FoundCell Is Nothing Then
            FirstAddr = FoundCell.Address
        End If
        
        n = 3   ' Start column for subjects
        
        Do Until FoundCell Is Nothing                          ' loop until no more matches
            n = n + 1                                          ' increment column count for "Result Date"
            c = FoundCell.Column                               ' Subject column
            .Cells(r, n) = ws1.Cells(1, c)                     ' Assign Subject to this teacher
            Set FoundCell = srange.FindNext(after:=FoundCell)  ' Find next occernce of this teacher
            If FoundCell.Address = FirstAddr Then
                Exit Do
            End If
        Loop
        '
        '******************************************************************
        '
        For c = 4 To lc + 3
            If .Cells(r, c) = "" Then Cells(r, c) = "Nil"  ' Set empty cells to "Nil"
        Next c
    
    Next r
    
End With


End Sub
Sub List_Teachers(lastr, lastc)
Dim rng As Range
Dim r As Range
Dim i As Integer
Dim j As Long
Dim n As Long
Dim txt As String
Dim ar As Variant
Dim arr() As Variant

Dim ws1 As Worksheet, ws2 As Worksheet

Set ws1 = Sheets("Base Sheet")
Set ws2 = Sheets("Result Sheet")

With ws1
    Set rng = .Range(.Cells(2, 1), .Cells(lastr, lastc))
End With
n = 0
ReDim arr(1 To 1)
'
'  Create unique list of teachers
'
With CreateObject("scripting.dictionary")

    For Each c In rng
        txt = c.Value
        If txt <> "" Then
            If Not .Exists(txt) Then
                n = n + 1
                .Add txt, n
                ReDim Preserve arr(1 To n)
               arr(n) = txt
             End If
         End If
    Next c
    
End With
    
    With ws2  ' "Result Data"
    
    .Range("B2:C100").ClearContents                                                  ' Clear Sr no. and Teacher columns
    .[C2].Resize(n) = Application.Transpose(arr)                                     ' Output list of teachres
    .Range("C2:C" & n + 1).Sort Key1:=Range("c1"), Order1:=xlAscending, Header:=xlNo ' Sort ascending
    
    .[C1] = "Name of Teacher"  ' Header
    
     For i = 1 To n  ' Add Sr No. column
     .Cells(i + 1, 2) = i
     Next i
     
    End With
    
End Sub

Hello, Thanks for reply,
code works well and fetch information correctly, however it is found that in Result Sheet, texts and info in nearby columns get erased and additional subject columns are added.

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

I'm glad I could teach the old-timer something.

Artik

Originally Posted by Artik

I'm glad I could teach the old-timer something.

Artik

Thanks friend for reply. Your code works smooth with speed. Just one small issue. When i add new name or update name of the teacher or subject, it gets included in between the list in result sheet. Due to this nearby data / information in other columns get erased.

That's what I thought, it can't be that simple.
Below is the corrected code.

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
    Dim varrOldResults As Variant
    Dim oDicOldRes  As Object

    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")
        varrOldResults = .Range("C6").CurrentRegion.Value

        'delete rows with old data (if exists)
        If UBound(varrOldResults) > 1 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

        'Restore old teachers' data (if existing)
        If UBound(varrOldResults) > 1 Then
            Set oDicOldRes = CreateObject("Scripting.Dictionary")

            For i = 2 To UBound(varrOldResults)
                oDicOldRes.Add varrOldResults(i, 2), Join(Array(varrOldResults(i, 8), varrOldResults(i, 9), varrOldResults(i, 10)), "<!!!>")
            Next i
            
            For i = 0 To oDic.Count - 1
              If oDicOldRes.Exists(oDic.Keys()(i)) Then
                v = Split(oDicOldRes(oDic.Keys()(i)), "<!!!>")
                .Range("I7").Offset(i).Resize(, UBound(v) + 1).Value = v
              End If
            Next i
        End If
        

        '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

Hello,
While executing code i got errors. Screenshots of these errors are attached.

Thank you.

If i delete that line then again old issue take place...

Hello thanks,
after code execution, values in nearby fields get deleted (except table headings). Also where subject names are blank, it do not show Nil.

Is it possible?
1. to add new name entry at the bottom of in result sheet.
2. In case of change / alter name, old entry will get deleted and new updated name will reflect at the bottom of result sheet.

Thanks

Hello
I have attached new sample file with new sheet 'Result Sheet Before Code' and 'Result Sheet after code'.

Result sheet in original file will exist but it will not contain any data. Data will get populated after execution of code as per shown in description in post no. 1 and also as per 'Result Sheet after Code'.


Thanks for your help.

Hello,
Code works well but when put any value in other area where code is not expected to work, it converts that value into Nil. Means code is expected to run in the range B to H column and from 5th row onward. but if i run the code 1st time it given result properly, then if record any value out of the given range (where code is not expected to work), then every where 'Nil' occurs.
Otherwise, code works truly well. Previous problem is solve in this code where if i add or alter name of the teacher then data do not get deleted.

I am thankful for your concern.