I briefly joined my wife at her practice to help her grow the business and figure out how to make things more efficient. One of the things I learned is that my wife created a sign-in sheet for the office in Microsoft Word. Every week she would open the file and manually enter the date for each day of the week and then print out the documents. I took over the responsibility for a month and it annoyed me due to how inefficient the process was and I decided to automate the entire thing. I couldn’t find a solution to the problem online so I had to roll my own and am sharing the code in case someone else can benefit from it.

Important Details

The script will calculate the first day and last day of the month and then do a loop to append the date in the “Day, Month day, Year” format (i.e. Thursday July 17, 2019) to a text field.

There are a few important steps involved to get the script working as is:

1. Create a Word doc with the first page that you want to duplicate.
2. Add a text field from the developer tab. To copy and paste the code below as-is, you’ll need to name it txtDate. This is where the date will be added. If you want a different field name, change the name at line 26 and 83. You can also change the date formats to suit your needs here as well.
3. Add a second blank page to the document. I was running into issues where the paste was appearing partially on the first. The blank page resolved this and I added code to remove the original page as well as the blank one from the beginning.

How to Use

Open up Word, then open up VBA, and copy and paste this snippet into a module. When you run the function, it’ll create a copy for every day of the month. I also created a function to start at a specific date in case you run it in the middle of the month.

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, "DDDD MMMM dd, YYYY")
          
        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

Sub CreateSigninsForMonthStartingDate()
    Dim Count As Integer
    Dim N As Integer
    Dim sCurrentMonth, sCurrentYear As String
    Dim sNewDate, sEndDay As String
    
    N = 1
    Count = 0

    iStartDay = InputBox("Which day do you want to start on?", "Starting Day", "1")
    Count = InputBox("Which day do you want to end on?", "Ending Day", Day(GetLastDayOfMonth))
    
    Do While Count > Day(GetLastDayOfMonth)
        sEndDay = InputBox("Which day do you want to end on?", "Ending Day", Day(GetLastDayOfMonth))
                    
        If iStartDay = vbNullString Or sEndDay = vbNullString Then
            MsgBox "You clicked cancel.", vbOKOnly, "Try again later!"
            Exit Sub
        End If
           
        If IsNumeric(CInt(sEndDay)) Then
            Count = CInt(sEndDay)
        End If
    Loop
    
    For CopyNumber = iStartDay 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, "DDDD MMMM dd, YYYY")
          
        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