Creating Workbooks from a list.

Hi Guys,

I have created a list form 5 workbooks and now i want to recreate the workbooks again. If any one could help it would be great. Here is the code so far.

Public Sub timetable()
Dim r As Range, start As Range
Dim timetable As Range
Dim up As Integer, hour As Integer, room As Integer, Back As Integer
Dim wb As Workbook, TheFile As String, MyPath As String
Dim time As String, group As String, day As String, classroom As String
Dim year As String
Const maxrooms = 13, maxhours = 9
Range("A2").Activate

MyPath = "C:\Documents and Settings\user\My Documents\Aidan"
ChDir MyPath
TheFile = Dir("*.xls")
Do While TheFile <> ""
Set wb = Workbooks.Open(MyPath & "\" & TheFile)
Set start = Range("B3")
start.Activate
Set r = start


Set timetable = Range(start, start.Offset(maxhours - 1, maxrooms - 1))
For Each r In timetable
r.Activate
up = r.Row - 2
Back = r.Column - 1

If r.Value <> "" Then classroom = r.Offset(-up, 0).Value

If r.Value <> "" Then time = r.Offset(0, -Back).Value

If r.Value <> "" Then group = r.Value

If r.Value <> "" Then day = ActiveWorkbook.Name

If r.Value <> "" Then
Set yearcheck = ActiveCell
End If

If yearcheck.Value Like "*3" Then
year = 3
ElseIf yearcheck.Value Like "*2" Then
year = 2
ElseIf yearcheck.Value Like "*1" Then
year = 1
Else: year = 1
End If

If r.Value <> "" Then
Windows("Aidan MAster").Activate
ActiveCell.Select
ActiveCell.Value = time
ActiveCell.Offset(0, 1).Activate
ActiveCell.Value = classroom
ActiveCell.Offset(0, 1).Activate
ActiveCell.Value = group
ActiveCell.Offset(0, 1).Activate
ActiveCell.Value = year
ActiveCell.Offset(0, 1).Activate
ActiveCell.Value = day
ActiveCell.Offset(1, -4).Activate
wb.Activate





End If

Next r
wb.Close
TheFile = Dir
Loop



End Sub