Creating a School Time Table

A

anuradhagrewal

Board Regular
Joined
Dec 3, 2020
Messages
85
Office Version
  1. 2010
Platform
  1. Windows
Hi
Attached is an excel file that is basically a school time table :rawdata.xlsx


I need your help to create a macros wherein from the fields mentioned in the file I get the following output for all the class/sections as shown in the image.

I want the changes when they are made in raw data file be automatically updated in the final output.
How can I do this. I am not able to understand.

Please advice

Regards

Anu
 

Attachments

  • output.png
    output.png
    18.4 KB · Views: 20

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
Sort by date Sort by votes
Assume main sheet named "TimeTable"
Like this?

rawdata.xlsm

drive.google.com drive.google.com
VBA Code: 
Option Explicit
Private Sub Worksheet_Activate()
class
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) <> "A1" Then Exit Sub
class
End Sub
Sub class()
Dim lr&, i&, j&, t&, rng, res
With Sheets("TimeTable")
    lr = .Cells(Rows.Count, "C").End(xlUp).Row
    rng = .Range("B3:G" & lr).Value
End With
res = Range("A2:M8").Value
For t = 1 To UBound(rng)
    If rng(t, 6) = Range("A1").Value Then
        For i = 3 To 7
            Debug.Print res(i, 1) & " | " & rng(t, 1), res(i, 1) = rng(t, 1)
            If res(i, 1) = Trim(rng(t, 1)) Then
               For j = 2 To 13
                    If res(1, j) = rng(t, 3) Then
                        res(i, j) = rng(t, 2)
                        GoTo nextT
                    End If
                Next
            End If
        Next
    End If
nextT:
Next
Range("A2:M8").Value = res
End Sub
 
Upvote 0
bebo021999 said:
Assume main sheet named "TimeTable"
Like this?

rawdata.xlsm

drive.google.com drive.google.com
VBA Code: 
Option Explicit
Private Sub Worksheet_Activate()
class
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) <> "A1" Then Exit Sub
class
End Sub
Sub class()
Dim lr&, i&, j&, t&, rng, res
With Sheets("TimeTable")
    lr = .Cells(Rows.Count, "C").End(xlUp).Row
    rng = .Range("B3:G" & lr).Value
End With
res = Range("A2:M8").Value
For t = 1 To UBound(rng)
    If rng(t, 6) = Range("A1").Value Then
        For i = 3 To 7
            Debug.Print res(i, 1) & " | " & rng(t, 1), res(i, 1) = rng(t, 1)
            If res(i, 1) = Trim(rng(t, 1)) Then
               For j = 2 To 13
                    If res(1, j) = rng(t, 3) Then
                        res(i, j) = rng(t, 2)
                        GoTo nextT
                    End If
                Next
            End If
        Next
    End If
nextT:
Next
Range("A2:M8").Value = res
End Sub
Click to expand...
Hi There
Nothing happened dear

Regards

Anu
 
Upvote 0
bebo021999 said:
Assume main sheet named "TimeTable"
Like this?

rawdata.xlsm

drive.google.com drive.google.com
VBA Code: 
Option Explicit
Private Sub Worksheet_Activate()
class
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) <> "A1" Then Exit Sub
class
End Sub
Sub class()
Dim lr&, i&, j&, t&, rng, res
With Sheets("TimeTable")
    lr = .Cells(Rows.Count, "C").End(xlUp).Row
    rng = .Range("B3:G" & lr).Value
End With
res = Range("A2:M8").Value
For t = 1 To UBound(rng)
    If rng(t, 6) = Range("A1").Value Then
        For i = 3 To 7
            Debug.Print res(i, 1) & " | " & rng(t, 1), res(i, 1) = rng(t, 1)
            If res(i, 1) = Trim(rng(t, 1)) Then
               For j = 2 To 13
                    If res(1, j) = rng(t, 3) Then
                        res(i, j) = rng(t, 2)
                        GoTo nextT
                    End If
                Next
            End If
        Next
    End If
nextT:
Next
Range("A2:M8").Value = res
End Sub
Click to expand...
Hi There
Is it possible that all the classes time table appear one under the other
For eg instead of using the drop down menu to select Class IA then the time table of class IA is shown
Instead of that when I run the macros all the time tables of all the classes are shown like
Class I A
{its time table}
(under this)
Class I B
{its time table}

And so on for all the classes.
That would really be helpful dear to see if any lecture is not overlapping with another.

You have done a fantastic job for me anyway

Regards

ANU
 
Upvote 0
The "Temp" sheet is used to store a template range for a class. This range will be sequentially copied to class sheets.
This code is placed in the sheet class and is triggered every time this sheet is activated.

rawdata.xlsm

drive.google.com drive.google.com
VBA Code: 
Option Explicit
Private Sub Worksheet_Activate()
class
End Sub
Sub class()
Dim lr&, i&, j&, t&, k&, r&, pos&, rng, res(), tempRng As Range
Dim dic As Object, key, day, hr
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Temp")
    Set tempRng = .Range("A1:M8") ' temporary range
    day = .Range("A4:A8").Value
    hr = .Range("B2:M2").Value
End With
ActiveSheet.Cells.Clear
With Sheets("TimeTable")
    lr = .Cells(Rows.Count, "C").End(xlUp).Row
    rng = .Range("B3:G" & lr).Value
End With
For i = 1 To UBound(rng)
    If Not dic.exists(rng(i, 6)) Then dic.Add rng(i, 6), ""
Next
For Each key In dic.keys
    t = t + 1: ReDim res(1 To 5, 1 To 12)
    pos = 9 * (t - 1) + 1
    For i = 1 To UBound(rng)
        If rng(i, 3) <> "" Then
            If key = rng(i, 6) Then
                On Error Resume Next
                j = WorksheetFunction.Match(Trim(rng(i, 1)), day, 0)
                r = WorksheetFunction.Match(rng(i, 3), hr, 0)
                On Error GoTo 0
                res(j, r) = rng(i, 2)
            End If
        End If
    Next
    tempRng.Copy Cells(pos, 1)
    Cells(pos, 1).Value = key
    Cells(pos + 3, 2).Resize(5, 12).Value = res
Next
End Sub
 
Upvote 0
It's a bit overkill but does the job :cool:

rawdata.xlsm

1 file sent via WeTransfer, the simplest way to send your files around the world
we.tl we.tl
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim myTable As Variant
  With Worksheets("Sheet2")
  myTable = .UsedRange.Offset(1).Resize(.UsedRange.Rows.Count - 1).Value
  End With
  
  For i = 1 To UBound(myTable, 1) - 1
    For j = i + 1 To UBound(myTable, 1)
      If myTable(i, 6) >= myTable(j, 6) Then
        For k = 1 To UBound(myTable, 2)
          temp = myTable(i, k)
          myTable(i, k) = myTable(j, k)
          myTable(j, k) = temp
        Next
      End If
    Next
  Next
  For i = 1 To UBound(myTable, 1) - 1
    For j = i + 1 To UBound(myTable, 1)
      If myTable(i, 4) <= myTable(j, 4) Then
        For k = 1 To UBound(myTable, 2)
          temp = myTable(i, k)
          myTable(i, k) = myTable(j, k)
          myTable(j, k) = temp
          Select Case k
          Case 4
          myTable(i, k) = Format$(myTable(i, k), "hh:mm")
          myTable(j, k) = Format$(myTable(j, k), "hh:mm")
          Case 5
          myTable(i, k) = Format$(myTable(j, k), "Medium Time")
          myTable(j, k) = Format$(myTable(j, k), "Medium Time")
          End Select
        Next
      End If
    Next
  Next
  Dim classes As Object, days As Object, hours As Object
  Set classes = CreateObject("Scripting.Dictionary")
  Set days = CreateObject("Scripting.Dictionary")
  Set hours = CreateObject("Scripting.Dictionary")
  
  For i = 1 To UBound(myTable, 1)
    If Not classes.Exists(Trim(myTable(i, 6))) Then
      classes.Add Trim(myTable(i, 6)), 1
    End If
  Next
  r = 2
  Dim daysOfWeek As Variant
  daysOfWeek = [{"Monday",False;"Tuesday",False;"Wednesday",False;"Thursday",False;"Friday",False;"Saturday",False;"Sunday",False}]
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  Worksheets("Schedule").UsedRange.EntireRow.Delete
  
  For i = 0 To classes.Count - 1
    For j = 1 To UBound(myTable, 1)
     If myTable(j, 6) = classes.Keys()(i) Then
       If Not days.Exists(Trim(myTable(j, 1))) Then
         days.Add Trim(myTable(j, 1)), 1
       End If
       If Not hours.Exists(Trim(myTable(j, 4))) Then
         hours.Add Trim(myTable(j, 4)), Trim(myTable(j, 2)) & "|" & Trim(myTable(j, 3)) & "|" & Trim(myTable(j, 5)) & "|" & 1
       End If
     End If
    Next

    For d = 1 To 7
      For k = 0 To days.Count - 1
        If days.Keys()(k) = daysOfWeek(d, 1) Then
          daysOfWeek(d, 2) = True
        End If
      Next
    Next
    With Worksheets("Schedule").Cells(r, 2)
      .Value = classes.Keys()(i)
      .Offset(1) = "Day"
      For d = 1 To 7
        If daysOfWeek(d, 2) Then
          .Offset(2 + d) = daysOfWeek(d, 1)
        End If
      Next
      For h = 0 To hours.Count - 1
        If Split(hours.Items()(h), "|")(1) <> "" Then
          .Offset(1, 1 + h) = Split(hours.Items()(h), "|")(1)
          .Offset(2, 1 + h) = hours.Keys()(h) & " - " & Split(hours.Items()(h), "|")(2)
        Else
          .Offset(1, 1 + h) = Split(hours.Items()(h), "|")(0)
          .Offset(2, 1 + h) = hours.Keys()(h) & " - " & Split(hours.Items()(h), "|")(2)
        End If
        temp = Format$(TimeValue(Split(hours.Items()(h), "|")(2)), "hh:mm") & " - " & Format$(TimeValue(Split(hours.Items()(h), "|")(2)) + (20 / 1440), "Medium Time")
        hours(hours.Keys()(h)) = h + 1
      Next
      .Offset(1, 1 + h) = temp
      c = 0
      For d = 1 To 7
        If daysOfWeek(d, 2) = True Then
          For h = 0 To hours.Count - 1
            For t = 1 To UBound(myTable, 1)
              If myTable(t, 3) <> "" Then
                If Trim(myTable(t, 1)) = daysOfWeek(d, 1) And Trim(myTable(t, 4)) = hours.Keys()(h) And Trim(myTable(t, 6)) = classes.Keys()(i) Then
                  .Offset(3 + c, hours.Items()(h)) = Trim(myTable(t, 2))
                  Exit For
                End If
              End If
            Next
          Next
          c = c + 1
        End If
      Next
      .Resize(, hours.Count + 2).Merge
      .Offset(1).Resize(2).Merge
      .Offset(1).HorizontalAlignment = xlCenter
      .Offset(1).VerticalAlignment = xlCenter
    End With
    hours.RemoveAll
    r = r + (days.Count + 4)
    days.RemoveAll
    For d = 1 To 7
      daysOfWeek(d, 2) = False
    Next
  Next
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question
Two dimensional dynamic named range over a pivot table not working as I thought
Replies
4
Views
330
ashleighbrown
A
J
  • Question
Copy 1 Column From A Table Of A Few Columns By Choosing Header Name
Replies
0
Views
370
junkyardforme
J
E
  • Question
Create different Excel files / sheets based on a Table slicer
Replies
0
Views
215
elisadovio
E
S
  • Question
Looking for Help to create an Excel or Access Database
Replies
5
Views
120
Micron
M
C
  • Solved
VBA to search for table from PDF File and copy and paste to Worksheet
Replies
4
Views
510
Alex Blakenburg
A

Forum statistics

Threads
1,215,287
Messages
6,124,075
Members
449,140
Latest member
SheetalDixit

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top