SimpleUser
New Member
- Joined
- Jun 20, 2016
- Messages
- 9
Hi. I found this on contextures and it creates monthly workbook with separate daily blank sheets and date as the tabname. How do I change it to copy a template sheet instead of creating blank sheets? Also, to add the code to change merged cell of A2:J2 to the date created each day as "DD MMM YYYY"?
I tried replacing the part where it creates the sheets to as below but I got some sub error
The working file I got from contextures.
The template I'm trying to duplicate with tabname as date and header <Date> in the 2nd merged cell. Much help is appreciated.
I tried replacing the part where it creates the sheets to as below but I got some sub error
VBA Code:
Sheets("Template").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = Format(DateSerial(yr, m, mDay), "dd mmm yyyy")
ActiveSheet.Range("A2:J2").Value = Format(DateSerial(yr, m, mDay), "dd mmm yyyy")The working file I got from contextures.
VBA Code:
Option Explicit
' Downloaded from www.contextures.com
'---------------------------------------------------------------------------------------
' Procedure : CreateBooksandSheets
' Author : Roger Govier, Technology 4 U
' Date : 13/01/2008 , modified 30 Nov 2008
' Purpose :
' Creates 12 workbooks named Jan YYYY.... Dec YYYY
' In each workbook, creates the number of sheets for each day in the month
' and names them Jan 01, Jan 02 etc.
' Deletes the standard Sheet1 to Sheet3 created as part of a normal workbook.
' Amended Nov 29 08
' 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. If there are less than 3, the previous version
' errored out. Also added Mike's suggestion for creating ordinal numbers.
' Amended Nov 28 2022 - by Debra Dalgleish
' in macro, changed file extension to xlsx
' changed workbook naming to yyyy_mm
' use eomonth function to get last day in month
'---------------------------------------------------------------------------------------
Sub CreateBooksandSheets()
'Dim month As String, year As String
Dim yr As Integer, m As Integer
Dim folder As String, filename As String
Dim mName As String, tabname As String
Dim mDay As Integer, mEnd As Integer
Dim ordinals As Boolean
Dim ws As Worksheet
Dim ext As String
Dim wbT As Workbook
On Error GoTo CreateBooksandSheets_Error
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
folder = ThisWorkbook.Path
ext = ".xlsx"
askyear:
yr = Format(Now(), "yyyy")
yr = InputBox("Enter the Year number required" _
& vbCrLf & "in the format of YYYY e.g. " & yr + 1 _
& vbCrLf & "" _
& vbCrLf & "This will determine the correct" _
& vbCrLf & "number of days for February." _
, "Enter Year Number", yr + 1)
If Val(yr) < 1999 And Val(yr) > 2100 Then
GoTo askyear
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, "Use Ordinals?")
Case vbYes
ordinals = True
Case vbNo
ordinals = False
End Select
For m = 1 To 12 ' i.e. for each of the 12 months of the year
mName = MonthName(m, True) 'select monthname in short Form
filename = "Keypress Access Log " & Format(m, "00") & " " & Format(mName, "MMM") & " " & yr 'See Chye's edit to save filename as eg. Keypress Access Log 03 Mar YYYY
' 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(filename & ext) Then
Select Case MsgBox("The file " & filename & ext _
& vbCrLf & "already exists." _
& vbCrLf & "Do you want to Overwrite this file?" _
& vbCrLf & "Cancel will stop the macro from continuing" _
, vbYesNoCancel Or vbExclamation Or vbDefaultButton2, _
"File Alreday Exists")
Case vbNo
GoTo nextmonth
Case vbCancel
GoTo exitsub
Case vbYes
End Select
End If
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:=folder & "\" & filename & ext
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 = mName
'delete any other sheets in the newly opened workbook
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> mName Then
ws.Delete
End If
Next
mEnd = Day(Application.WorksheetFunction _
.EoMonth(DateSerial(yr, m, 1), 0))
For mDay = 1 To mEnd
If ordinals <> True Then
'Sheets("Template").Copy After:=Sheets(Sheets.Count)
'ActiveSheet.Name = Format(DateSerial(yr, m, mDay), "dd mmm yyyy")
'ActiveSheet.Range("A2:J2").Value = Format(DateSerial(yr, m, mDay), "dd mmm yyyy")
Worksheets.Add(After:=Sheets(Sheets.Count)). _
Name = Format(DateSerial(yr, m, mDay), "dd mmm yyyy")
'if you don't want the month name included, just the day number, then
'change the format above to just "dd" instead of "mmm dd"
Else
Select Case mDay
Case 1, 21, 31
tabname = mDay & "st"
Case 2, 22
tabname = mDay & "nd"
Case 3, 23
tabname = mDay & "rd"
Case Else
tabname = mDay & "th"
End Select
' if you don't want the Month in the sheet name, just the day number
' then rem out the next line
tabname = tabname & " " & mName & " " & Format(DateSerial(yr, m, mDay), "yyyy")
Worksheets.Add(After:=Sheets(Sheets.Count)). _
Name = tabname
End If
Next mDay
' now delete the first sheet created with just the month name
Sheets(mName).Delete
' save the workbook and close
ActiveWorkbook.Close Savechanges:=True
' 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.
nextmonth:
Next m
Call MsgBox("All monthly files have been created" _
& vbCrLf & "in folder " & folder _
, vbInformation Or vbDefaultButton1, _
"Macro completed")
GoTo exitsub
CreateBooksandSheets_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")" _
& vbCrLf _
& " in procedure CreateBooksandSheets of Module Module1"
Application.DisplayAlerts = True
exitsub:
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
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
' Alternative method of creating ordinal number.
' This function was posted by Excel MVP Rick Rothstein in the Newsgroups on 01 Dec 2008
Function Ordinal(Number As Long) As String
Ordinal = Number & Mid$("thstndrdthththththth", 1 - 2 * _
((Number) Mod 10) * (Abs((Number) Mod 100 - 12) > 1), 2)
End FunctionThe template I'm trying to duplicate with tabname as date and header <Date> in the 2nd merged cell. Much help is appreciated.
| excelcreateyrmthworkbks.xlsm | ||||||||||||
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| A | B | C | D | E | F | G | H | I | J | |||
| 1 | Keypress Access Log | |||||||||||
| 2 | <Date> | |||||||||||
| 3 | S/No | Requester | Company | SR No. | Key | Owner | Purpose | Time Out | Time In | Escort by | ||
| 4 | ||||||||||||
| 5 | ||||||||||||
| 6 | ||||||||||||
| 7 | ||||||||||||
| 8 | ||||||||||||
| 9 | Check by: | Verified by: | ||||||||||
| 10 | ||||||||||||
Template | ||||||||||||
