Added the code and your suggestion for using Ordinals in the date names
Code as posted below
Sub CreateBooksandSheets()
Dim month As String, year As String, tabname As String
Dim i As Long, m As Long, myday As Long
Dim ordinals As Boolean
Dim ws As Worksheet
On Error GoTo CreateBooksandSheets_Error
Application.DisplayAlerts = False
askyear:
year = InputBox("Enter the Year number required" _
& vbCrLf & "in the format of 2008" _
& vbCrLf & "" _
& vbCrLf & "This will determine the correct" _
& vbCrLf & "number of days for February." _
, "Select which Year", "2008")
If Val(year) <= 1 Then Exit Sub
If Val(year) < 1999 And Val(year) > 3000 Then
GoTo askyear
End If
For m = 1 To 12 ' i.e. for each of the 12 months of the year
month = MonthName(m, True) 'select monthname in short Form
' test if file for Month already exists, If so ask user whether they
want to overwrite the file
' uses the IsFile function below this module
If IsFile(month & ".xls") Then
Select Case MsgBox("The file " & month & ".xls" _
& vbCrLf & "already exists." _
& vbCrLf & "Do you want to Overwrite?" _
, vbYesNo Or vbCritical Or vbDefaultButton2,
"File Already Exists")
Case vbNo
GoTo nextmonth
Case vbYes
End Select
End If
' ask if the user want to use ordinals for the day numbers 1st, 2nd,
3rd etc.
' added after suggestion by Mike Fogleman
Select Case MsgBox("Do you want to use Ordinals for the number
format" _
& vbCrLf & "e.g Jan 1st, Jan 2nd etc." _
& vbCrLf & "Answer YES if required, or NO to
leave as Jan 01, Jan 02" _
, vbYesNo Or vbQuestion Or vbDefaultButton1,
Application.Name)
Case vbYes
ordinals = True
Case vbNo
ordinals = False
End Select
Workbooks.Add 'create new Workbook and save
as Month name
On Error Resume Next ' user has said Ok to overwrite to ignore
warning
ActiveWorkbook.SaveAs Filename:=month & ".xls", _
FileFormat:=xlNormal, Password:="",
WriteResPassword:="", _
ReadOnlyRecommended:=False,
CreateBackup:=False
On Error GoTo CreateBooksandSheets_Error ' set error point back
'add new sheet after existing sheets in workbook and name it same as
month
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = month
'delete any other sheets in the newly opened workbook
' amended from deleting the array of Sheet1, Sheet2, Sheet3 after
it was pointed
' out by Mike Fogleman, there is no guarantee that the user allows
new
' workbooks to be created with 3 sheets.
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> month Then
ws.Delete
End If
Next
'Create date for first of month in cell A1
ActiveSheet.Cells(1, 1) = "01" & "/" & month & "/" & year
'create formula for last day of month in cell B1
ActiveSheet.Cells(1, 2).FormulaR1C1 =
"=DATE(YEAR(RC[-1]),MONTH(RC[-1])+1,0)"
'create formula to give day number of last day of month in C1
ActiveSheet.Cells(1, 3).FormulaR1C1 = "=DAY(RC[-1])"
' loop for as many days as there are in month (from day 2) through
column A, adding 1 day
' to previous days value
For i = 2 To Cells(1, 3).Value
Cells(i, 1) = Cells(i, 1).Offset(-1, 0).Value + 1
Next i
' loop for as many days in the month, adding a new worksheet, and
giving it the name
' of each cell in column A for the first sheet created (Month),
setting the format to be
' mmm dd or Jan 01
For i = 1 To Cells(1, 3).Value
myday = Day(Sheets(month).Cells(i, 1).Value)
If ordinals <> True Then
Worksheets.Add(After:=Sheets(Sheets.Count)). _
Name = Format(Sheets(month).Cells(i, 1), "mmm dd")
Else
Select Case myday
Case 1, 21, 31
tabname = myday & "st"
Case 2, 22
tabname = myday & "nd"
Case 3, 23
tabname = myday & "rd"
Case Else
tabname = myday & "th"
End Select
tabname = month & " " & tabname
Worksheets.Add(After:=Sheets(Sheets.Count)). _
Name = tabname
End If
Next i
' now delete the first sheet created with just the month name
Sheets(month).Delete
' step up month number to next month and repeat procedure
' this is the point we jump to if file exists and user says NO to
overwrite.
ActiveWorkbook.Close Savechanges:=True
nextmonth:
Next m
On Error GoTo 0
Application.DisplayAlerts = True
Exit Sub
CreateBooksandSheets_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure
CreateBooksandSheets of Module Module1"
Application.DisplayAlerts = True
End Sub
Function IsFile(s As String) As Boolean
'tests whether a file exists. Returns True if it does or False
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
IsFile = fs.FileExists(s)
End Function
