Thread: rearrange data for a school timetables

Originally Posted by JBeaucaire

Lots of extra work.

Yes
But, for a newbie, extra work means learning
So thanks a lot for helping me to learn and to solve my problem !!
So here we go (tested and working )
the first Macro

Option Explicit
Sub CreateTeacherScheduleRTL()
'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.7 To 0.999:       c = 1   '17:00
            Case 0.66 To 0.6999:     c = 2   '16:00
            Case 0.625 To 0.65:      c = 3   '15:00
            Case 0.58 To 0.62:       c = 4   '14:00
             Case 0.45 To 0.57:       c = 5   '11:00
             Case 0.375 To 0.4:       c = 6   '9:00
            Case 0.33 To 0.374:      c = 7   '8: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("A2") = "17:00"
    Range("B2") = "16:00"
    Range("C2") = "15:00"
    Range("D2") = "14:00"
    Range("E2") = "11:00"
    Range("F2") = "10:00"
    Range("G2") = "09:00"
    Range("H2") = "08:00"
    Range("I3") = "Monday1"
    Range("I4") = "Tuesday1"
    Range("I5") = "Wednesday1"
    Range("I6") = "Thursday1"
    Range("I7") = "Friday1"
    Range("I8") = "Saturday1"
    Columns("A:A").EntireColumn.AutoFit
    Range("A2:I8").Borders.LineStyle = xlContinuous
    Range("A3:H8").WrapText = True
End Sub

Second Macro needs no changes !!

The third Macro:

Sub MergeClassesRTL()
'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, "I"), 3))   'first 3 characters of first cell in this row
        Case "mon", "tue", "wed", "thu", "fri", "sat"
            For c = 1 To 7      '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 = 7 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

Very nice indeed. Well done.

If that takes care of your need, be sure to EDIT your original post, click Go Advanced and mark the PREFIX box [SOLVED].


(Also, use the blue "scales" icon in our posts to leave Reputation Feedback, it is appreciated)

Originally Posted by JBeaucaire

(Also, use the blue "scales" icon in our posts to leave Reputation Feedback, it is appreciated)

Done !

Originally Posted by JBeaucaire

If that takes care of your need,

Nearly..
except for one thing, I tried to do it myself
I tried a loop to copy rows from output made by third Macro
with no succes
I want to output data based on days, on day per sheet
Each row represents a teacher
like this
http://img268.imageshack.us/img268/2452/underdays.png

I would change

    Select Case t
        Case 0.7 To 0.999: c = 1    '17:00
        Case 0.66 To 0.6999: c = 2    '16:00
        Case 0.625 To 0.65: c = 3    '15:00
        Case 0.58 To 0.62: c = 4    '14:00
        Case 0.45 To 0.57: c = 5    '11:00
        Case 0.375 To 0.4: c = 6    '9:00
        Case 0.33 To 0.374: c = 7    '8:00
    End Select

to

    Select Case TimeValue(t)
        Case Is >= #4:48:00 PM#: c = 1
        Case Is >= #3:15:00 PM#: c = 2
        Case Is >= #3:00:00 PM#: c = 3
        Case Is >= #1:55:00 PM#: c = 4
        Case Is >= #10:48:00 AM#: c = 5
        Case Is >= #9:00:00 AM#: c = 6
        Case Is >= #7:55:00 AM#: c = 7
        Case Else
            ' what now?
    End Select

... because

1. It's readable

2. It doesn't have gaps between cases like the first code

3. It caters to dates/times that include a date

4. The added case allows testing for invalid data

Thanks a lot shg
I will try it, and let you now

Again a big thanks to JBeaucaire
I modified the second macro, so I can create a worksheet containing the day's data like this
http://img268.imageshack.us/img268/2452/underdays.png

it doesnot loop to automatically create all worksheet days, I have to modify the row reference each time the produce the desired day's shedule
Here is the Macro
all credits go to JBeaucaire

Sub DayMasterListingMonday()
Dim ws As Worksheet, NR As Long
NR = 3
    If Not Evaluate("ISREF(DayMasterList!A1)") Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "DayMasterListMonday"
    Else
        Sheets("DayMasterListMonday").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").Copy Sheets("DayMasterListMonday").Range("I" & NR)
                ws.Range("B3:I3").Copy Sheets("DayMasterListMonday").Range("A" & NR)
                NR = NR + 1
        End If
    Next ws
    
Cells.Columns.AutoFit
End Sub

Here is the result's screenshoot:
http://img35.imageshack.us/img35/272...ayschedule.png