Create table for each teacher

[YasserKhalil]

Hello everyone
I have data of classes in sheet1 (subjects and teachers) and I need to create tables for each teacher
Attachment has just one table for one teacher .. that's to grab all the related subjects and classes of that teacher as shown in sheet2
But in sheet2 it is just one table and I need all the tables for all the teachers existed in sheet1

Thanks advanced for help

[mdmackillop]

Can you post the code that you have attempted?

[p45cal]

In the attached, I have re-arranged your data on a new sheet called NewData.
In Sheet1 I've added a pivot table. You can choose a different Class in cell J3.
In Sheet2 I've added another pivot table. You can choose a different Teacher in cell K2.
Adjust/play with the layout of the tables until you get something you like.
There are 9 other sheets added. These were created automatically by built-in Excel functionality:
Select a cell in a pivot table you like the look of, then in the ribbon, in the Options tab of the PivotTable Tools tab, in the Pivot Options section, choose from the Options dropdown: Show Report Filter Pages.
Click OK in the resultant dialogue box and the extra sheets will be created automatically.

[YasserKhalil]

Thanks a lot for replies. In fact I don't get working well on pivot tables and I need that by macros if possible
All what I need is to create similar tables to the table existing in Sheet2. Consider that table as template and this table can be copied fr each person but the data withing the tables will be changeable of course

[Leith Ross]

Hello Yasser,

Here is a macro solution for you. The attached workbook has the macro shown here attached to a button on "Sheet1". A new sheet has been added which is called "Template". This has the formatted cells and labels as shown on "Sheet2".



Option Explicit


Sub CreateSchedules()


Dim c As Long
Dim Cell As Range
Dim ClassId As String
Dim Dict As Object
Dim DstWks As Worksheet
Dim r As Long
Dim Rng As Range
Dim RngBeg As Range
Dim row As Long
Dim Schedule As Variant
Dim SrcWks As Worksheet
Dim Subject As String
Dim Table As Range
Dim Teacher As Variant
Dim TmpltWks As Worksheet

Set SrcWks = ThisWorkbook.Worksheets("Sheet1")
Set DstWks = ThisWorkbook.Worksheets("Sheet2")
Set TmpltWks = ThisWorkbook.Worksheets("Template")

Set Rng = SrcWks.Range("D2", SrcWks.Cells(Rows.Count, "D").End(xlUp))

Set Cell = Rng.Find("class*", Rng.Cells(Rng.Rows.Count, 1), xlValues, xlPart, xlByRows, xlNext, False, False, False)

If Cell Is Nothing Then Exit Sub

Application.ScreenUpdating = False

Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMOde = vbTextCompare

row = Cell.row
Set RngBeg = Cell

Do
Set Table = Cell.CurrentRegion
Set Table = Intersect(Table, Table.Offset(4, 2))
ClassId = Cell.Value

For r = 1 To Table.Rows.Count Step 2
For c = 1 To Table.Columns.Count
Subject = Table.Cells(r, c)
Teacher = Table.Cells(r + 1, c)
If Teacher <> "" Then
If Not Dict.exists(Teacher) Then
ReDim Schedule(1 To 10, 1 To 5)
Schedule(r, c) = Subject
Schedule(r + 1, c) = ClassId
Dict.Add Teacher, Schedule
Else
Schedule = Dict(Teacher)
If InStr(1, Schedule(r, c), Subject) = 0 Then
Schedule(r, c) = Subject
Schedule(r + 1, c) = ClassId
Else
Schedule(r, c) = Schedule(r, c) & "/" & Subject
Schedule(r + 1, c) = Schedule(r + 1, c) & "/" & ClassId
End If
Dict(Teacher) = Schedule
End If
End If
Next c
Next r

Set Cell = Rng.FindNext(Cell)
If Cell.Address = RngBeg.Address Then Exit Do
Loop

DstWks.UsedRange.Clear

For Each Teacher In Dict.Keys
TmpltWks.Range("A1").CurrentRegion.Copy
DstWks.Cells(row, "A").PasteSpecial Paste:=xlPasteAll

Set Rng = DstWks.Cells(row, "A").CurrentRegion
Rng.Cells(1, "D").Value = Teacher
Intersect(Rng, Rng.Offset(4, 2)).Value = Dict(Teacher)

row = row + Rng.Rows.Count + 2
Next Teacher

Application.ScreenUpdating = True
Application.CutCopyMode = False
Application.Goto DstWks.Range("A1")

End Sub

[YasserKhalil]

That's amazing and fascinating .. Really awesome Mr. Leith
I will try to study the code to lean from this magic
Thank you very very much for this great help
Best and kind regards for all who shared this issue