Microsoft Office Forums - View Single Post - [Solved] Create a page for each day of the year (minor? tweaks)

VbaNewbie · 01-01-2023, 05:54 AM

Dear all,

first of all, happy new year!

I would like to create a journal for 2023, creating one page (with the same content) for each day of the year - having the date on the top of the page.
I found the fantastic vba script here.

Code:

Sub CreateSigninsForMonth()
    Dim N As Integer
    Dim sCurrentMonth, sCurrentYear As String
    Dim sNewDate As String
    
    N = 1

    Count = Day(GetLastDayOfMonth)
           
    For CopyNumber = 1 To Count
    
        With Selection
            .GoTo wdGoToPage, wdGoToAbsolute, 1
            .Bookmarks("\Page").Range.Copy
            .Paste
        End With
    
        With ActiveSheet
       
         sCurrentMonth = Format(Date, "mmmm")
         sCurrentYear = Format(Date, "yyyy")
         sNewDate = (CopyNumber & " " & sCurrentMonth & " " & sCurrentYear)
        
        ActiveDocument.FormFields("txtDate").Result = Format(sNewDate, "dd. MMMM")
          
        End With
        N = N + 1
    Next CopyNumber
    
    'Delete template + blank page
    For i = 1 To 2
    With ActiveDocument
        strt = .GoTo(wdGoToPage, wdGoToLast).Start
        Set r = .Range(strt - 1, .Range.End)
        r.Delete
    End With
    Next

End Sub


Function GetFirstDayOfMonth(Optional dtmDate As Date = 0) As Date
    
    ' Return the first day in the specified month.
    If dtmDate = 0 Then
        ' Use the current date if none was specified
        dtmDate = Date
    End If
    
    GetFirstDayOfMonth = DateSerial(Year(dtmDate), Month(dtmDate), 1)

End Function

Function GetLastDayOfMonth(Optional dtmDate As Date = 0) As Date
    
    ' Return the last day in the specified month.
    If dtmDate = 0 Then
        
         ' Use the current date if none was specified
        dtmDate = Date
    
    End If
    
    GetLastDayOfMonth = DateSerial(Year(dtmDate), Month(dtmDate) + 1, 0)
End Function

While it does work well, I encounter two problems:

1) It adds the the pages/dates in reverse order (jan. 1st is on the last page).
I tried changing the code and adding .Collapse wdCollapseEnd, but the results are the same.

Code:

        With Selection
            .GoTo wdGoToPage, wdGoToAbsolute, 1
            .Bookmarks("\Page").Range.Copy
            .Collapse wdCollapseEnd
            .Paste
        End With

How do I need to change the code to have Jan. 1st on the first page, 2nd on the second, etc.

2) Now the script only adds one month. Is it possible to to the same for the whole year? So that I have 365 days at the end?

I tried adding an additional For loop, which starts at 0 and goes to 12 and always adds +1 to the date. However, it does not work. I still only see January (and it does not recognize that not all months have 31 days...)

Here my changes:

Code:

Sub CreateSigninsForMonth()
    Dim N As Integer
    Dim nMonth As Integer
    Dim sCurrentMonth, sCurrentYear As String
    Dim sNewDate As String
    
    N = 1
    nMonth = 0

    Count = Day(GetLastDayOfMonth)
    
    month_last = 11
    
    For month_first = 0 To month_last
           
        For CopyNumber = 1 To Count
        
            With Selection
                .GoTo wdGoToPage, wdGoToAbsolute, 1
                .Bookmarks("\Page").Range.Copy
                .Paste
            End With
        
            With ActiveSheet
           
             sCurrentMonth = Format(Date + nMonth, "mmmm")
             sCurrentYear = Format(Date, "yyyy")
             sNewDate = (CopyNumber & " " & sCurrentMonth & " " & sCurrentYear)
            
            ActiveDocument.FormFields("txtDate").Result = Format(sNewDate, "dd. MMMM")
              
            End With
            N = N + 1
        Next CopyNumber
        
        'Delete template + blank page
        For i = 1 To 2
        With ActiveDocument
            strt = .GoTo(wdGoToPage, wdGoToLast).Start
            Set r = .Range(strt - 1, .Range.End)
            r.Delete
        End With
        Next
    nMonth = nMonth + 1
    Next

End Sub

Thank you for any help!