Please see the attached workbook, (the code is also repeated below for 'browsing' purposes).
I have implemented the 'InputBox' for names that are repeated, or too long, as I feel this is most flexible.
You may also notice that when I copy the timetable sheets I do not copy the 'Sheet', but rather insert a new blank sheet, and then copy the cells from one sheet to the other. This avoids the issue with repeatedly copying a worksheet within a workbook, (http://support.microsoft.com/kb/210684).
It then reapplies the 'Print_Area' that is defined on the TimeTable templates. I don't know if you are using the 'Print_Area' at all, but as it was defined on the original templates I have copied it to the timesheets. If you don't need it then just comment out the green text.
You will note that there are a few areas of code that are commented out. This is because during testing I was outputing the Timetables to a different workbook so that I could delete and restart them easily. I have left the code areas in below in case you find them useful.
To re-enable the outputing to a different workbook you need to comment the blue text, and uncomment the red text 
Please let me know how you get on.
Option Explicit
Sub Create_New_Sheets()
Dim current_row As Long, src_row As Long
Dim timetable_orig As Worksheet, timetable_personal As Worksheet
Dim classes As Integer, level As String
Dim timetable_name As String
'Dim output_filename As String, Output_WB As Workbook
' Stop screen Flicker & increase speed
Application.ScreenUpdating = False
'' open the output workbook _
'output_filename = ThisWorkbook.Path & "\" & "Output Timetables.xls"
'If Dir(output_filename) <> "" Then
' Set Output_WB = Workbooks.Open(output_filename)
'Else
' Set Output_WB = Workbooks.Add
' Output_WB.SaveAs output_filename
'End If
' Initialise the row to start working on
current_row = 9
' Cycle through each row
With ThisWorkbook.Worksheets("Student Class & Room List")
Do While .Cells(current_row, "A").Value <> ""
' How many classes?
If .Cells(current_row, "A").Value = .Cells(current_row + 1, "A") And _
.Cells(current_row, "C").Value = .Cells(current_row + 1, "C") Then
' This row and next match double class
classes = 2
Else
' This row doesn't match the next, single class
classes = 1
End If
' What level are they at?
If LCase(.Cells(current_row, "E").Value) Like "upper-int*" Or _
LCase(.Cells(current_row, "E").Value) Like "advanced*" Then
level = "A"
Else
level = "B"
End If
' Now we now how many classes and at what level we know which sheet to use
Set timetable_orig = ThisWorkbook.Worksheets("Schedule " & level & " GE" & classes)
' Copy the sheet (actually insert a blank, then copy the cells and re-set the print_area _
this avoids the issue with repeated copying worksheets detailed in http://support.microsoft.com/kb/210684
'With Output_WB
With ThisWorkbook
Set timetable_personal = Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
timetable_orig.Cells.Copy Destination:=timetable_personal.Cells
With timetable_personal
.Names.Add Name:="Print_Area", RefersTo:="='" & Replace(.Name, "'", "''") & "'!$A$1:$F$" & .Cells(.Rows.Count, "A").End(xlUp).Row
End With
End With
' Fill in the details
timetable_name = .Cells(current_row, "A").Value & " " & .Cells(current_row, "C")
timetable_personal.Range("A5").Value = "Name: " & timetable_name
' Sheet name is limited to 31 characters. If student name is longer then ask user for option?
If Len(timetable_name) > 31 Or Sheet_Exists(timetable_name) Then ', Output_WB.Name) Then
Do
timetable_name = InputBox("Student Name is too long to use as sheet name or sheet already exists." & vbCrLf & _
"Enter a new name that is 31 characters or less", _
"TimeTable Name", _
timetable_name)
Loop While Len(timetable_name) > 31 Or (timetable_name = "") Or Sheet_Exists(timetable_name) ', Output_WB.Name)
End If
timetable_personal.Name = timetable_name
' fill in class details
For src_row = 0 To 1
timetable_personal.Cells(((src_row * 2) + 5), "D") = .Cells(current_row + src_row, "E")
timetable_personal.Cells(((src_row * 2) + 5), "E") = .Cells(current_row + src_row, "H")
timetable_personal.Cells(((src_row * 2) + 5), "F") = .Cells(current_row + src_row, "G")
If classes = 1 Then Exit For
Next
'Move onto the next pupil
current_row = current_row + classes
Loop
End With
'' Remove the default sheets of a new workbook
'If Output_WB.Worksheets.Count > 3 Then
' Application.DisplayAlerts = False
' For Each timetable_personal In Output_WB.Worksheets
' If timetable_personal.Name = "Sheet1" Or _
' timetable_personal.Name = "Sheet2" Or _
' timetable_personal.Name = "Sheet3" Then timetable_personal.Delete
' Next
' Application.DisplayAlerts = True
'End If
' Re-Enable screen updating
ThisWorkbook.Worksheets(1).Activate
Application.ScreenUpdating = True
MsgBox "TimeTables Complete"
End Sub
Function Sheet_Exists(WorksheetName As String, Optional WorkbookName As String = "") As Boolean
Dim ws As Worksheet
Set ws = Nothing
If WorkbookName = "" Then WorkbookName = ThisWorkbook.Name
On Error Resume Next
Set ws = Workbooks(WorkbookName).Worksheets(WorksheetName)
On Error GoTo 0
If ws Is Nothing Then
Sheet_Exists = False
Else
Sheet_Exists = True
End If
End Function
LinkBack URL
About LinkBacks
Register To Reply
Re: Run Macro 1 if Value X exists or Macro B if Value X exists twice
Bookmarks