How do I copy a worksheet for each day of the year?

K

Kaybay

I'm trying to create a new sheet for each day of the year. It needs to
contain the day and date but I really don't want to copy and paste 2 years of
forms and manually change the date. Please can anybody help.
 
H

Harald Staff

Hi

Run this littme macro when your master sheet is the active sheet:

Sub MakeYear()
Dim SH As Worksheet
Dim D As Date, Y As Long
Set SH = ActiveSheet
Y = Val(InputBox("Year:"))
If Y < 2000 Then Exit Sub
If Y > 2100 Then Exit Sub
Application.ScreenUpdating = False
For D = DateSerial(Y, 1, 1) To DateSerial(Y, 12, 31)
Application.StatusBar = D
SH.Copy after:=Sheets(Sheets.Count)
ActiveSheet.Range("A1").Value = D
ActiveSheet.Name = Format(D, "mmm dd")
Next
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub

HTH. best wishes Harald
 
K

Kaybay

Hi Harold,

It's like magic!
Thank you very much. I really appreciate the help.

Kay
 
H

Harald Staff

Glad it worked for you Kay.
(Your boss will understand that a job like that would take at least 2-3 long
unpaid evenings, and buy you an expensive dinner :)

Best wishes Harald
 
D

David

That is just brilliant!
What would I have to change to do a particular month instead of a whole year?

David
 
D

David

This is the code I am using, I just can't figure out how to get the new
worksheets to be the same as the first worksheet:

Sub CreateWorksheetsByDate()

Dim myDate As Variant
Dim iCtr As Long
Dim myStr As String
Dim testwks As Worksheet
Dim SH As Worksheet
Set SH = ActiveSheet
myDate = InputBox(Prompt:="Enter the first day of the Month you want to
Create", _
Default:=Format(Date, "mm/dd/yy"))
'Default:=Format(Date, "mmmm dd, yyyy"))
If IsDate(myDate) = False Then
MsgBox "Please try later"
Exit Sub
End If

Application.ScreenUpdating = False

myDate = CDate(myDate)

For iCtr = DateSerial(Year(myDate), Month(myDate), 1) _
To DateSerial(Year(myDate), Month(myDate) + 1, 0)
Select Case Weekday(iCtr)
'Case Is = vbSunday, vbSaturday (Does all days, remove ' does
only weekdays)
'do nothing
Case Else
'myStr = Format(iCtr, "yyyy_mm_dd_dddd")
myStr = Format(iCtr, "dddd mm-dd")
Set testwks = Nothing
On Error Resume Next
Set testwks = Worksheets(myStr)
On Error GoTo 0

If testwks Is Nothing Then
Set testwks _
= Worksheets.Add(after:=Worksheets(Worksheets.Count))
testwks.Name = myStr
End If
End Select
Next iCtr

Worksheets("Setup").Activate

Application.ScreenUpdating = True


End Sub

Thanks!
 
D

David

Got it! This is what I did:
Sub MakeMonth()
Dim SH As Worksheet
Dim myDate As Variant
Dim D As Date, Y As Long
Set SH = ActiveSheet

myDate = InputBox(Prompt:="Enter the first day of the Month you want to
Create", _
Default:=Format(Date, "mm/dd/yy"))
'If Y < 2000 Then Exit Sub
'If Y > 2100 Then Exit Sub
Application.ScreenUpdating = False
myDate = CDate(myDate)

'For D = DateSerial(Y, 1, 1) To DateSerial(Y, 12, 31)
For iCtr = DateSerial(Year(myDate), Month(myDate), 1) To
DateSerial(Year(myDate), Month(myDate) + 1, 0)
Application.StatusBar = D
SH.Copy after:=Sheets(Sheets.Count)
'ActiveSheet.Range("A1").Value = D
ActiveSheet.Name = Format(iCtr, "dddd mm-dd")
Next
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub

Thanks again for the initial code!
 
D

Den

This looks like something I want to do for a daily log i'm making. Can you
tell me how to create the macro?
 
G

Gord Dibben

Sub Add_Year_Sheets()
Dim dFrom As Date, dTo As Date
Dim d As Date, i As Long

dFrom = CDate("1/Jan/07") ' edit to suit
dTo = CDate("31/Dec/07") ' edit to suit
dTo = dFrom + 364 ' 365 if above year is a leap year

n = Worksheets.Count - 1

For d = dFrom To dTo
'If Weekday(CDate(d), 2) < 6 Then
n = n + 1
Worksheets.Add(After:=Worksheets(n)).Name = Format(d, "ddd dd mmm")
'End If
Next

Worksheets(1).Activate
End Sub


Gord Dibben MS Excel MVP
 
G

Gord Dibben

I may have misread your post.

The macro I supplied adds new sheets and names them.

Do you also want the incremented date entered in a cell on each sheet?

Do you want to copy a specific sheet rather than create new sheets?


Gord
 
T

tutink777

Gord,

I want to copy a specific sheet I already created (inlcuding its formulas,
etc) and change the name of that sheet, 55 times. Can you tell me the macro
to use to do that? Thanks so much for any help.

Michelle
 
G

Gord Dibben

What would the naming convention be for the copied sheets?

Here's a macro from Dave Peterson that copies a sheet named Template and
names each copy according to a list of names on a sheet named List.

Post back with more info if not what you want.

Sub CreateNameSheets()
' by Dave Peterson
' List sheetnames required in col A in a sheet: List
' Sub will copy sheets based on the sheet named as: Template
' and name the sheets accordingly

Dim TemplateWks As Worksheet
Dim ListWks As Worksheet
Dim ListRng As Range
Dim mycell As Range

Set TemplateWks = Worksheets("Template")
Set ListWks = Worksheets("list")
With ListWks
Set ListRng = .Range("a1", .Cells(.Rows.Count, "A").End(xlUp))
End With

For Each mycell In ListRng.Cells
TemplateWks.Copy After:=Worksheets(Worksheets.Count)
On Error Resume Next
ActiveSheet.Name = mycell.Value
If Err.Number <> 0 Then
MsgBox "Please fix: " & ActiveSheet.Name
Err.Clear
End If
On Error GoTo 0
Next mycell

End Sub


Gord
 
Top