Yes, sure, no problem, here It is :
Code:
Sub DoMonths()
Dim J As Integer
Dim K As Integer
Dim sMo(12) As String
sMo(1) = "January"
sMo(2) = "February"
sMo(3) = "March"
sMo(4) = "April"
sMo(5) = "May"
sMo(6) = "June"
sMo(7) = "July"
sMo(8) = "August"
sMo(9) = "September"
sMo(10) = "October"
sMo(11) = "November"
sMo(12) = "December"
Application.ScreenUpdating = False
For J = 1 To 12
Sheets(1).Copy after:=Sheets(Sheets.Count)
With ActiveSheet
.Name = sMo(J) & " " & Year(Date)
For K = 1 To Day(DateSerial(Year(Date), J + 1, 0))
.Cells(1, K).Value = DateSerial(Year(Date), J, K)
Next K
.Range(.Cells(1, K), .Cells(1, Columns.Count)).EntireColumn.Delete
For K = .Shapes.Count To 1 Step -1
If UCase(Left(.Shapes(K).Name, 3)) <> "OBJ" Then
.Shapes(K).Delete
End If
Next K
End With
Next J
Application.ScreenUpdating = True
Sheets(1).Activate
End Sub
This code for macro executes on CmdButton (or any desired shape) to add new sheets which are named by months in the year. It adds days in the months too (starting in A1 cell to the end of the row), for the current year. Existing sheets (normally sheet 1-3) are left intact. When new sheets, named after month are inserted all shapes are deleted (such as CmdButton). Code also deletes every columns after the end of days, correspoding to month !
A few advice of changing code for your purposes :
If you want all sheets to be automatically changed for month sequence (no sheets 1-3 left), insert into code - right after defining variables:
- you can do that also for sMo(2),sMo(3)...
If you don't want to delete column after the end of days, simply delete or put comment (') on these commands :
Code:
.Range(.Cells(1, K), .Cells(1, Columns.Count)).EntireColumn.Delete
If you have worksheet where your dates not start in A1, you can add this code and apply changes which fits your needs:
Code:
.Cells(2, 4 + K).Value = DateSerial(Year(Date), J, K)
- this is example for Row 2, and Column 5 (E2 cell)
If you want to delete only certain shapes (or buttons, activeX), change your code with name of object:
Code:
If UCase(Left(.Shapes(K).Name, 3)) <> "CMD" Then
- This example deletes shapes with "CMD" name in it !
And finally, If you want to clear contents of copied sheet in all new month sheets :
Code:
Sub ClearContents()
Dim lngCounter As Long
For lngCounter = 2 To 12
Sheets(lngCounter).Range("B2:AE2").ClearContents - adjust your desired range and try It (haven't done It myself so far, I hope It works)
Next lngCounter
End Sub