Thread: rearrange data for a school timetables

Well
I am a total newbie, but I am wiling to learn
I have some raw data in a .ods file produced by a timetabling program
like this:

http://img228.imageshack.us/img228/1...wtimetable.png

I need data to be formated like this layout:
http://img193.imageshack.us/img193/9...ttimetable.png

Basically, I need to
1- pull the table's head (in red) from teacher column E

2- pull subject, student set, and room from and put them together into a single cell, according to day and period
fo example, data from row 2, (with A2=friday1 and B2=09:00) from row spreadsheet
would be put at C7 int the formatted timetable

3- in order to prepare data , I also need to check if the a cell in day column contain the number 2
if so transform period by adding 6
for example, for day tuesday2
tranform day tuesday2 period 08:00 into tuesday1 period 14:00
tranform day tuesday2 period 09:00 into into tuesday1 period 15:00
tranform day tuesday2 period 10:00 into into into tuesday1 period 16:00
and so on for other XXX2 days

I attached the .xsl file
and a wanted timetable layout
Hope I explained my problem clearely

Try this macro on your sheet, it will create and format the sheets as needed. Install these macros into a regular module.

Option Explicit
Sub CreateTeacherSchedule()
'JBeaucaire  (8/24/2009)
Dim LR As Long, i As Long, r As Long, c As Long
Dim Str As String, t As Double

Sheets("farabitimetable").Activate
LR = Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To LR
'create sheet if needed
    Str = Cells(i, "E").Text
    If Str = "" Then Exit Sub
    If Not Evaluate("ISREF('" & Str & "'!A1)") Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Str
        Call FormatSheet(Str)
        Sheets("farabitimetable").Activate
    End If
'insert data
    'Check day and adjust time if needed
    If InStr(Cells(i, "A"), "2") > 0 Then
        t = Cells(i, "B") + 0.25
    Else
        t = Cells(i, "B")
    End If
    'Find correct column
        Select Case t
            Case 0.33 To 0.374:      c = 2   '8:00
            Case 0.375 To 0.4:       c = 3   '9:00
            Case 0.41 To 0.44:       c = 4   '10:00
            Case 0.45 To 0.57:       c = 5   '11:00
            Case 0.58 To 0.62:       c = 6   '14:00
            Case 0.625 To 0.65:      c = 7   '15:00
            Case 0.66 To 0.6999:     c = 8   '16:00
            Case 0.7 To 0.999:       c = 9   '17:00
        End Select
    'Find correct row
        Select Case LCase(Left(Cells(i, "A"), 3))
            Case "mon":     r = 3
            Case "tue":     r = 4
            Case "wed":     r = 5
            Case "thu":     r = 6
            Case "fri":     r = 7
            Case "sat":     r = 8
        End Select
    'Copy data into proper cell
        Sheets(Str).Cells(r, c).Value = Cells(i, "D") & "; " & Cells(i, "C") & "; " & Cells(i, "G")
Next i
End Sub


Sub FormatSheet(Str As String)
    Range("A1:I1").HorizontalAlignment = xlCenterAcrossSelection
    Range("A1:I1").Font.FontStyle = "Bold"
    Range("A1:I1").Font.ColorIndex = 3
    Range("A1") = Str
    Range("B2") = "8:00"
    Range("C2") = "9:00"
    Range("D2") = "10:00"
    Range("E2") = "11:00"
    Range("F2") = "14:00"
    Range("G2") = "15:00"
    Range("H2") = "16:00"
    Range("I2") = "17:00"
    Range("A3") = "Monday1"
    Range("A4") = "Tuesday1"
    Range("A5") = "Wednesday1"
    Range("A6") = "Thursday1"
    Range("A7") = "Friday1"
    Range("A8") = "Saturday1"
    Columns("A:A").EntireColumn.AutoFit
    Range("A2:I8").Borders.LineStyle = xlContinuous
    Range("B3:I8").WrapText = True
End Sub

How to use the macro:

1. Open up your workbook
2. Get into VB Editor (Press Alt+F11)
3. Insert a new module (Insert > Module)
4. Copy and Paste in your code (given above)
5. Get out of VBA (Press Alt+Q)
6. Save your sheet

The macro is installed and ready to use. Press Alt-F8 and select it from the macro list.

Originally Posted by jadawl01

the macro is working fine except for some cases:
for example: teacher ar2 has a course on friday, period 17:00
Acording to initial data, this course should be on friday, period 09:00

Of course I played around a bit with your data as I was constructing the macro. I see some of the numbers I changed didn't get changed back.

That's OK, though, you're running this macro on YOUR sheet, not mine, right?

Last question: cold you please comment the macro , so I can understand what is going ?
This way, I can learn more about macros an VB

Sure!

Option Explicit
Sub CreateTeacherSchedule()
'JBeaucaire  (8/24/2009)
Dim LR As Long      'The will be used to find the last row
Dim i As Long       'this will be for our row by row loop
Dim r As Long       'for storing which row (day) on the teacher sheet to put the class in
Dim c As Long       'for storing which column (time) on the teacher sheet to put the class in
Dim Str As String   'teacher's name, used to create sheetnames too
Dim t As Double     'for storing the time as we loop through the classes

'Activate the main data table
    Sheets("farabitimetable").Activate
'Spot the last row of data
    LR = Range("A" & Rows.Count).End(xlUp).Row

'Loop through all the rows starting at row 2, down through the last row
For i = 2 To LR
    'store the teacher's name in the Str variable
        Str = Cells(i, "E").Text
    'if we reached the end of the data, abort, we're done
        If Str = "" Then Exit Sub
    'Test if sheet exists
        If Not Evaluate("ISREF('" & Str & "'!A1)") Then
        'if not, add a new sheet with teacher's name
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Str
            'format the sheet using the other macro
            Call FormatSheet(Str)
            'come back to the main data sheet
            Sheets("farabitimetable").Activate
        End If
'insert data
    'Check day and adjust time by 6 hours if a "2" exists in day name
    If InStr(Cells(i, "A"), "2") > 0 Then
        'Store the time +6 hours in the t-variable
        t = Cells(i, "B") + 0.25
    Else
        'Store the time in the t-variable
        t = Cells(i, "B")
    End If
    'Find correct column based on the value in "t"
        Select Case t           'store the column value in "c"
        'these are decimal values that match Excel's hidden values for time
            Case 0.33 To 0.374:      c = 2   '8:00
            Case 0.375 To 0.4:       c = 3   '9:00
            Case 0.41 To 0.44:       c = 4   '10:00
            Case 0.45 To 0.57:       c = 5   '11:00
            Case 0.58 To 0.62:       c = 6   '14:00
            Case 0.625 To 0.65:      c = 7   '15:00
            Case 0.66 To 0.6999:     c = 8   '16:00
            Case 0.7 To 0.999:       c = 9   '17:00
        End Select
    'Find correct row based on the day name and store in the "r" variable
        Select Case LCase(Left(Cells(i, "A"), 3))
            Case "mon":     r = 3
            Case "tue":     r = 4
            Case "wed":     r = 5
            Case "thu":     r = 6
            Case "fri":     r = 7
            Case "sat":     r = 8
        End Select
    'Copy data into proper cell using all the variables we've collected
        Sheets(Str).Cells(r, c).Value = Cells(i, "D") & "; " & Cells(i, "C") & "; " & Cells(i, "G")
Next i

End Sub


Sub FormatSheet(Str As String)
'This macro formats a blank sheet to match the desired layout
'row1 A1:A1 formatted as a single cell without "merging" it
    Range("A1:I1").HorizontalAlignment = xlCenterAcrossSelection
'Set the font to bold and the color to red, insert the teacher's name
    Range("A1:I1").Font.FontStyle = "Bold"
    Range("A1:I1").Font.ColorIndex = 3
    Range("A1") = Str
'Fill in the time labels
    Range("B2") = "8:00"
    Range("C2") = "9:00"
    Range("D2") = "10:00"
    Range("E2") = "11:00"
    Range("F2") = "14:00"
    Range("G2") = "15:00"
    Range("H2") = "16:00"
    Range("I2") = "17:00"
'Fill in the day labels
    Range("A3") = "Monday1"
    Range("A4") = "Tuesday1"
    Range("A5") = "Wednesday1"
    Range("A6") = "Thursday1"
    Range("A7") = "Friday1"
    Range("A8") = "Saturday1"
'Autofit column A
    Columns("A:A").EntireColumn.AutoFit
'Turn on the box grid for the whole table
    Range("A2:I8").Borders.LineStyle = xlContinuous
'Allow word wrapping in the main table
    Range("B3:I8").WrapText = True
End Sub

Would you want that in addition to the extra sheets or instead of? We can add a MASTER listing at the end, pretty easy.

Here's a new routine added separately. You can leave the command I added at the end of the main routine and it will run it automatically, or you can remove it from there and run it manually when you want.

Option Explicit
Sub CreateTeacherSchedule()
'JBeaucaire  (8/25/2009)
Dim LR As Long      'The will be used to find the last row
Dim i As Long       'this will be for our row by row loop
Dim r As Long       'for storing which row (day) on the teacher sheet to put the class in
Dim c As Long       'for storing which column (time) on the teacher sheet to put the class in
Dim Str As String   'teacher's name, used to create sheetnames too
Dim t As Double     'for storing the time as we loop through the classes
Application.ScreenUpdating = False

'Activate the main data table
    Sheets("farabitimetable").Activate
'Spot the last row of data
    LR = Range("A" & Rows.Count).End(xlUp).Row

'Loop through all the rows starting at row 2, down through the last row
For i = 2 To LR
    'store the teacher's name in the Str variable
        Str = Cells(i, "E").Text
    'if we reached the end of the data, abort, we're done
        If Str = "" Then GoTo ExitDoor
    'Test if sheet exists
        If Not Evaluate("ISREF('" & Str & "'!A1)") Then
        'if not, add a new sheet with teacher's name
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Str
            'format the sheet using the other macro
            Call FormatSheet(Str)
            'come back to the main data sheet
            Sheets("farabitimetable").Activate
        End If
'insert data
    'Check day and adjust time by 6 hours if a "2" exists in day name
    If InStr(Cells(i, "A"), "2") > 0 Then
        'Store the time +6 hours in the t-variable
        t = Cells(i, "B") + 0.25
    Else
        'Store the time in the t-variable
        t = Cells(i, "B")
    End If
    'Find correct column based on the value in "t"
        Select Case t           'store the column value in "c"
        'these are decimal values that match Excel's hidden values for time
            Case 0.33 To 0.374:      c = 2   '8:00
            Case 0.375 To 0.4:       c = 3   '9:00
            Case 0.41 To 0.44:       c = 4   '10:00
            Case 0.45 To 0.57:       c = 5   '11:00
            Case 0.58 To 0.62:       c = 6   '14:00
            Case 0.625 To 0.65:      c = 7   '15:00
            Case 0.66 To 0.6999:     c = 8   '16:00
            Case 0.7 To 0.999:       c = 9   '17:00
        End Select
    'Find correct row based on the day name and store in the "r" variable
        Select Case LCase(Left(Cells(i, "A"), 3))
            Case "mon":     r = 3
            Case "tue":     r = 4
            Case "wed":     r = 5
            Case "thu":     r = 6
            Case "fri":     r = 7
            Case "sat":     r = 8
        End Select
    'Copy data into proper cell using all the variables we've collected
        Sheets(Str).Cells(r, c).Value = Cells(i, "D") & "; " & Cells(i, "C") & "; " & Cells(i, "G")
Next i
ExitDoor:
    
    MasterListing
    Application.ScreenUpdating = True
End Sub


Sub FormatSheet(Str As String)
'This macro formats a blank sheet to match the desired layout
'row1 A1:A1 formatted as a single cell without "merging" it
    Range("A1:I1").HorizontalAlignment = xlCenterAcrossSelection
'Set the font to bold and the color to red, insert the teacher's name
    Range("A1:I1").Font.FontStyle = "Bold"
    Range("A1:I1").Font.ColorIndex = 3
    Range("A1") = Str
'Fill in the time labels
    Range("B2") = "8:00"
    Range("C2") = "9:00"
    Range("D2") = "10:00"
    Range("E2") = "11:00"
    Range("F2") = "14:00"
    Range("G2") = "15:00"
    Range("H2") = "16:00"
    Range("I2") = "17:00"
'Fill in the day labels
    Range("A3") = "Monday1"
    Range("A4") = "Tuesday1"
    Range("A5") = "Wednesday1"
    Range("A6") = "Thursday1"
    Range("A7") = "Friday1"
    Range("A8") = "Saturday1"
'Autofit column A
    Columns("A:A").EntireColumn.AutoFit
'Turn on the box grid for the whole table
    Range("A2:I8").Borders.LineStyle = xlContinuous
'Allow word wrapping in the main table
    Range("B3:I8").WrapText = True
End Sub

Sub MasterListing()
Dim ws As Worksheet, NR As Long
NR = 1
    If Not Evaluate("ISREF(MasterList!A1)") Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "MasterList"
    Else
        Sheets("MasterList").Activate
        Cells.Clear
    End If

    For Each ws In Worksheets
        If ws.Name <> "Feuil1" And ws.Name <> "Feuil2" And _
            ws.Name <> "farabitimetable" And ws.Name <> "MasterList" Then
                ws.Range("A1:I8").Copy Sheets("MasterList").Range("A" & NR)
                NR = NR + 9
        End If
    Next ws
    
Cells.Columns.AutoFit
End Sub

Well
It worked for me
I add it as a separate macro
I am making progress !! Now I am able to understand what is going
First, we test if a sheet named "MasterList" already exist (but connont really understand:MasterList!A1 )

    If Not Evaluate("ISREF(MasterList!A1)") Then

if not, create it:

       Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "MasterList"

otherwise, activate it, and empty all cells content

        Sheets("MasterList").Activate
        Cells.Clear

We only want to copy sheet with name different from feuil1, feuil2 and farabitimetables

        If ws.Name <> "Feuil1" And ws.Name <> "Feuil2" And _
            ws.Name <> "farabitimetable" And ws.Name <> "MasterList" Then

then, we copy all sheets, one by one to our Masterlist sheet

 ws.Range("A1:I8").Copy Sheets("MasterList").Range("A" & NR)

we left an empty row :

 NR = NR + 9

I changed it 3 rows apart by : NR = NR + 11
From other tutorials on internet I understand that you refers to range by to left and bottom right corners !!!
But I cant really understand this reference:
Range("A" & NR)

Lastely, I would like to merge adjcent cells in a row, if they have same content regarding column C (students set)

this:
http://img401.imageshack.us/img401/5168/before.png
to be formatted like this
http://img523.imageshack.us/img523/3314/afterx.png

Again, run this a separate macro, or add a line to the bottom of the main macro to activate it automatically as part of that sequence.

Sub MergeClasses()
'JBeaucaire (8/26/2009)
Dim LR As Long      'stores position of last row of data
Dim r As Long       'used to loop through rows 1 at a time
Dim c As Long       'used to loop through columns 1 at a time
Dim FrstC As Range  'stores the first address of current match
Dim LstC As Range   'stores the last address of current match
Application.DisplayAlerts = False

Sheets("MasterList").Activate
LR = Range("A" & Rows.Count).End(xlUp).Row  'stores last row of data

For r = 1 To LR     'loop through all the ROWS one at a time
    Select Case LCase(Left(Cells(r, "A"), 3))   'first 3 characters of first cell in this row
        Case "mon", "tue", "wed", "thu", "fri", "sat"
            For c = 2 To 8      'scroll through columns 2:8 looking for adjacent matches
                If Cells(r, c) <> "" And Cells(r, c) = Cells(r, c + 1) Then
                    If FrstC Is Nothing Then Set FrstC = Cells(r, c)
                    Set LstC = Cells(r, c + 1)
                Else    'if current test isn't a match, check to see if FrstC is empty, if not, merge the current stored cell addresses
                    If Not FrstC Is Nothing Then
                        Range(FrstC, LstC).Merge
                        'clear values for next match
                            Set FrstC = Nothing
                            Set LstC = Nothing
                    End If
                End If
                'When we've reached the last column to check, merge cells if there are stored addresses
                    If c = 8 And Not FrstC Is Nothing Then
                        Range(FrstC, LstC).Merge
                        'clear values for next match
                            Set FrstC = Nothing
                            Set LstC = Nothing
                    End If
            Next c
    End Select
Next r

Cells.Columns.AutoFit
Cells.Rows.AutoFit
Application.DisplayAlerts = True
End Sub

In the previous macro, the Evaluate(ISREF... line is simply Excel running a worksheet formula in memory instead of a cell to see what the answer is. In VBA, this is a very simple way to see a sheet exists by trying to look at cell A1 on that sheet.

The NR variable is the "next row" numerically stored. The first time through the loop, that translates into "A1", the next time through "A10", etc.

hanks so much for help, I really appreciate it
Again, worked like a charm !
I only noticed that if I run the last macro from MasterList sheet, it formats the active range only (one teacher's timetable)
If I run it from farabitimetable sheet (original data sheet) it foramts all teacher's timetables
But this is not a real issue at all.

Now, I will try to format sheet Right To Left (arabic), so I will edit all the tree macros, then I will come back to you with results
Hope I can accheive it

Before formatting timetable Right To Left, I tried modifying first macro to acheive directly the result obtained by secod macro without creating a sheet for every single teacher

please, take a look a the code bellow
I didnot excute it, because, I am sure it is weired somewhere
I surely did some idiot edits !!
Basically, I "imitated" your code, mixed with some knowledge coming from my intensive readings in the last 3 days
I created a new sheet called Masterlist2, I removed all lines which was used to create a new sheet for every teacher
then I added a variable "s" to make an offset between each teacher's timetable in the same sheet

Option Explicit
Sub CreateTeacherSchedule()
'JBeaucaire  (8/24/2009)
Dim LR As Long      'The will be used to find the last row
Dim i As Long       'this will be for our row by row loop
Dim r As Long       'for storing which row (day) on the teacher sheet to put the class in
Dim s As Long       'for storing  row offset where for next teacher's timetable
Dim c As Long       'for storing which column (time) on the teacher sheet to put the class in
Dim Str As String   'teacher's name, used to create sheetnames too
Dim t As Double     'for storing the time as we loop through the classes
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "masterlist2"

	

'Activate the main data table
    Sheets("farabitimetable").Activate
'Spot the last row of data
    LR = Range("A" & Rows.Count).End(xlUp).Row
s = 0
'Loop through all the rows starting at row 2, down through the last row
For i = 2 To LR



    'store the teacher's name in the Str variable
        Str = Cells(i, "E").Text
    'if we reached the end of the data, abort, we're done
        If Str = "" Then Exit Sub
		'Activate masterlist2 sheet
    Sheets("masterlist2").Activate

            'format the sheet using the other macro
            Call FormatSheet
            'come back to the main data sheet
            Sheets("farabitimetable").Activate
        
'insert data
    'Check day and adjust time by 6 hours if a "2" exists in day name
    If InStr(Cells(i, "A"), "2") > 0 Then
        'Store the time +6 hours in the t-variable
        t = Cells(i, "B") + 0.25
    Else
        'Store the time in the t-variable
        t = Cells(i, "B")
    End If
    'Find correct column based on the value in "t"
        Select Case t           'store the column value in "c"
        'these are decimal values that match Excel's hidden values for time
            Case 0.33 To 0.374:      c = 2   '8:00
            Case 0.375 To 0.4:       c = 3   '9:00
            Case 0.41 To 0.44:       c = 4   '10:00
            Case 0.45 To 0.57:       c = 5   '11:00
            Case 0.58 To 0.62:       c = 6   '14:00
            Case 0.625 To 0.65:      c = 7   '15:00
            Case 0.66 To 0.6999:     c = 8   '16:00
            Case 0.7 To 0.999:       c = 9   '17:00
        End Select
    'Find correct row based on the day name and store in the "r" variable
        Select Case LCase(Left(Cells(i, "A"), 3))
            Case "mon":     r = 3
            Case "tue":     r = 4
            Case "wed":     r = 5
            Case "thu":     r = 6
            Case "fri":     r = 7
            Case "sat":     r = 8
        End Select
    'Copy data into proper cell using all the variables we've collected
        Sheets("masterlist2").Cells(r+s, c).Value = Cells(i, "D") & "; " & Cells(i, "C") & "; " & Cells(i, "G")
		s = s + 9
Next i

End Sub


Sub FormatSheet
'This macro formats a blank sheet to match the desired layout
'row1 A1:A1 formatted as a single cell without "merging" it
    Range("A1:I1").Offset(s).HorizontalAlignment = xlCenterAcrossSelection
'Set the font to bold and the color to red, insert the teacher's name
    Range("A1:I1")...Offset(s).Font.FontStyle = "Bold"
    Range("A1:I1")..Offset(s).Font.ColorIndex = 3
    Range("A1") = Str
'Fill in the time labels
    Range("B2")..Offset(s) = "8:00"
    Range("C2")..Offset(s) = "9:00"
    Range("D2")..Offset(s) = "10:00"
    Range("E2")..Offset(s) = "11:00"
    Range("F2")..Offset(s) = "14:00"
    Range("G2")..Offset(s) = "15:00"
    Range("H2")..Offset(s) = "16:00"
    Range("I2")..Offset(s) = "17:00"
'Fill in the day labels
    Range("A3")..Offset(s) = "Monday1"
    Range("A4")..Offset(s) = "Tuesday1"
    Range("A5")..Offset(s) = "Wednesday1"
    Range("A6")..Offset(s) = "Thursday1"
    Range("A7")..Offset(s) = "Friday1"
    Range("A8")..Offset(s) = "Saturday1"
'Autofit column A
    Columns("A:A")..Offset(s).EntireColumn.AutoFit
'Turn on the box grid for the whole table
    Range("A2:I8")..Offset(s).Borders.LineStyle = xlContinuous
'Allow word wrapping in the main table
    Range("B3:I8")..Offset(s).WrapText = True
End Sub

I don't know what you mean by right to left. But if you want to "skip" the creation of individual sheets, the logic of the entire set of macros would actually have to be redone.

That's not necessary. Leave them as separate, let them create, merge, format...and now delete the unneeded extra sheets.

This new set of macros includes the new one and ran as a whole in 2 seconds on the sample sheet you posted.

Option Explicit
Sub CreateTeacherSchedule()
'JBeaucaire  (8/24/2009)
Dim LR As Long      'The will be used to find the last row
Dim i As Long       'this will be for our row by row loop
Dim r As Long       'for storing which row (day) on the teacher sheet to put the class in
Dim c As Long       'for storing which column (time) on the teacher sheet to put the class in
Dim Str As String   'teacher's name, used to create sheetnames too
Dim t As Double     'for storing the time as we loop through the classes
Application.ScreenUpdating = False

'Activate the main data table
    Sheets("farabitimetable").Activate
'Spot the last row of data
    LR = Range("A" & Rows.Count).End(xlUp).Row

'Loop through all the rows starting at row 2, down through the last row
For i = 2 To LR
    'store the teacher's name in the Str variable
        Str = Cells(i, "E").Text
    'if we reached the end of the data, abort, we're done
        If Str = "" Then GoTo ExitDoor
    'Test if sheet exists
        If Not Evaluate("ISREF('" & Str & "'!A1)") Then
        'if not, add a new sheet with teacher's name
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Str
            'format the sheet using the other macro
            Call FormatSheet(Str)
            'come back to the main data sheet
            Sheets("farabitimetable").Activate
        End If
'insert data
    'Check day and adjust time by 6 hours if a "2" exists in day name
    If InStr(Cells(i, "A"), "2") > 0 Then
        'Store the time +6 hours in the t-variable
        t = Cells(i, "B") + 0.25
    Else
        'Store the time in the t-variable
        t = Cells(i, "B")
    End If
    'Find correct column based on the value in "t"
        Select Case t           'store the column value in "c"
        'these are decimal values that match Excel's hidden values for time
            Case 0.33 To 0.374:      c = 2   '8:00
            Case 0.375 To 0.4:       c = 3   '9:00
            Case 0.41 To 0.44:       c = 4   '10:00
            Case 0.45 To 0.57:       c = 5   '11:00
            Case 0.58 To 0.62:       c = 6   '14:00
            Case 0.625 To 0.65:      c = 7   '15:00
            Case 0.66 To 0.6999:     c = 8   '16:00
            Case 0.7 To 0.999:       c = 9   '17:00
        End Select
    'Find correct row based on the day name and store in the "r" variable
        Select Case LCase(Left(Cells(i, "A"), 3))
            Case "mon":     r = 3
            Case "tue":     r = 4
            Case "wed":     r = 5
            Case "thu":     r = 6
            Case "fri":     r = 7
            Case "sat":     r = 8
        End Select
    'Copy data into proper cell using all the variables we've collected
        Sheets(Str).Cells(r, c).Value = Cells(i, "D") & "; " & Cells(i, "C") & "; " & Cells(i, "G")
Next i
ExitDoor:

    MasterListing
    MergeClasses
    DeleteSheets
    Application.ScreenUpdating = True
End Sub


Sub FormatSheet(Str As String)
'This macro formats a blank sheet to match the desired layout
'row1 A1:A1 formatted as a single cell without "merging" it
    Range("A1:I1").HorizontalAlignment = xlCenterAcrossSelection
'Set the font to bold and the color to red, insert the teacher's name
    Range("A1:I1").Font.FontStyle = "Bold"
    Range("A1:I1").Font.ColorIndex = 3
    Range("A1") = Str
'Fill in the time labels
    Range("B2") = "8:00"
    Range("C2") = "9:00"
    Range("D2") = "10:00"
    Range("E2") = "11:00"
    Range("F2") = "14:00"
    Range("G2") = "15:00"
    Range("H2") = "16:00"
    Range("I2") = "17:00"
'Fill in the day labels
    Range("A3") = "Monday1"
    Range("A4") = "Tuesday1"
    Range("A5") = "Wednesday1"
    Range("A6") = "Thursday1"
    Range("A7") = "Friday1"
    Range("A8") = "Saturday1"
'Autofit column A
    Columns("A:A").EntireColumn.AutoFit
'Turn on the box grid for the whole table
    Range("A2:I8").Borders.LineStyle = xlContinuous
'Allow word wrapping in the main table
    Range("B3:I8").WrapText = True
End Sub

Sub MasterListing()
'JBeaucaire  (8/25/2009)
Dim ws As Worksheet, NR As Long
NR = 1
    If Not Evaluate("ISREF(MasterList!A1)") Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "MasterList"
    Else
        Sheets("MasterList").Activate
        Cells.Clear
    End If

    For Each ws In Worksheets
        If ws.Name <> "Feuil1" And ws.Name <> "Feuil2" And _
            ws.Name <> "farabitimetable" And ws.Name <> "MasterList" Then
                ws.Range("A1:I8").Copy Sheets("MasterList").Range("A" & NR)
                NR = NR + 9
        End If
    Next ws
    
Cells.Columns.AutoFit
End Sub

Sub MergeClasses()
'JBeaucaire (8/26/2009)
Dim LR As Long      'stores position of last row of data
Dim r As Long       'used to loop through rows 1 at a time
Dim c As Long       'used to loop through columns 1 at a time
Dim FrstC As Range  'stores the first address of current match
Dim LstC As Range   'stores the last address of current match
Application.DisplayAlerts = False

Sheets("MasterList").Activate
LR = Range("A" & Rows.Count).End(xlUp).Row  'stores last row of data

For r = 1 To LR     'loop through all the ROWS one at a time
    Select Case LCase(Left(Cells(r, "A"), 3))   'first 3 characters of first cell in this row
        Case "mon", "tue", "wed", "thu", "fri", "sat"
            For c = 2 To 8      'scroll through columns 2:8 looking for adjacent matches
                If Cells(r, c) <> "" And Cells(r, c) = Cells(r, c + 1) Then
                    If FrstC Is Nothing Then Set FrstC = Cells(r, c)
                    Set LstC = Cells(r, c + 1)
                Else    'if current test isn't a match, check to see if FrstC is empty, if not, merge the current stored cell addresses
                    If Not FrstC Is Nothing Then
                        Range(FrstC, LstC).Merge
                        'clear values for next match
                            Set FrstC = Nothing
                            Set LstC = Nothing
                    End If
                End If
                'When we've reached the last column to check, merge cells if there are stored addresses
                    If c = 8 And Not FrstC Is Nothing Then
                        Range(FrstC, LstC).Merge
                        'clear values for next match
                            Set FrstC = Nothing
                            Set LstC = Nothing
                    End If
            Next c
    End Select
Next r

Cells.Columns.AutoFit
Cells.Rows.AutoFit
Application.DisplayAlerts = True
End Sub

Sub DeleteSheets()
'JBeaucaire  (8/28/2009)
Dim ws As Worksheet
Application.DisplayAlerts = False
    
    For Each ws In Worksheets
        If ws.Name <> "Feuil1" And ws.Name <> "Feuil2" And _
            ws.Name <> "farabitimetable" And ws.Name <> "MasterList" Then _
                ws.Delete
    Next ws
    
Application.DisplayAlerts = True
End Sub

Yes
you are right: this way our macros will be modular, so I can use "modules" separatelly or in conjonction

About Right To Left
I mean timetable should be read frm Right To Left like this
-17:00 --16:00 -- 15:00 -- 14:00 -- 11:00 -- 10:00 -- 09:00 -- 08:00 -
---___-----___-------___-----___------___-------___--------___------___----Mnday
---___-----___-------___-----___------___-------___-------___-------___----Tuesday

and so on ..
( later, timetables will be translated into Arabic language, which is Right To Left)
But I think I can do it myself simply by inverting references to Columns here:

         'these are decimal values that match Excel's hidden values for time
           Case 0.66 To 0.6999:      c = 2   '17:00 instead of c = 2   '08:00
            Case 0.625 To 0.65:       c = 3   '16:00 instead of c = 2   '09:00

and so on...

and also in FormatSheet subroutine..
Here is the changes:

'Fill in the time labels
    Range("B2") = "17:00"  instead of "8:00"
    Range("C2") = "16:00"  instead of "9:00"


'Fill in the day labels
    Range("I3") = "Monday1" instead of Range("A3") = "Monday1" 
    Range("I4") = "Tuesday1" instead of  Range("A4") = "Tuesday1"

and so on ...

am I right ?

Yes, you are on the right track, but imagine if you had simply presented the "output" in that desired format, you wouldn't have to do any of that, I could have just given you what you needed.

You'll have to also examine the "copy" code and make sure it encompasses the new range properly.

And the MERGE code and make sure it is processing the correct columns still, if those have changed overall position in any way.

Lots of extra work.