Creating a School Time Table

A

anuradhagrewal

Board Regular
Joined
Dec 3, 2020
Messages
87
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: 34

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
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

M
  • Question Question
Pivot table and graph for member data for a non-profit
Replies
0
Views
160
Manexcel
M
S
  • Question Question
Have formula bar reflect the link to a cell
Replies
6
Views
148
Peter_SSs
Peter_SSs
M
  • Question Question
Formula Calculation is Inadvertently Switching from Automatic to Manual...
Replies
0
Views
266
MNexcelguy19
M
S
  • Question Question
VBA code to determine InDesign Layout
Replies
6
Views
525
Akuini
Akuini
H
  • Solved
Create list of last(family) names when parents have children in more than 1 class
Replies
7
Views
172
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,224,823
Messages
6,181,183
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

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