PlayGround

Attribute VB_Name = "Module1"
Option Explicit
Private Sub ShowSchedule()
 Worksheets(2).Select
End Sub
Private Sub NewWeek()

    Dim lngCopyDetails As Long
    
    Const EDITABLE_GRID_ROWS = 96
    Const EDITABLE_GRID_COLS = 21
    Const EDITABLE_GRID_OFFSET_ROW = 1
    Const EDITABLE_GRID_OFFSET_COL = 2
    Const DAYS_IN_WEEK = 7
    Const SELECT_ROW = 2
    Const SELECT_COL = 4
    
    On Error Resume Next
    
    lngCopyDetails = MsgBox("この週の詳細内容を新しいスケジュールにコピーしますか?", vbYesNoCancel, "詳細をコピーしますか?")
    If lngCopyDetails = vbCancel Then Exit Sub
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        ActiveSheet.Copy before:=ActiveSheet
        With ActiveSheet.Range("WeekStartDate")
            .Value = .Value + DAYS_IN_WEEK
            .Parent.Name = Format(.Value, "m 月 d 日 ;@")
            .Offset(SELECT_ROW, SELECT_COL).Select
            If vbNo = lngCopyDetails Then
                .Offset(EDITABLE_GRID_OFFSET_ROW, _
                        EDITABLE_GRID_OFFSET_COL).Resize(EDITABLE_GRID_ROWS, _
                                                         EDITABLE_GRID_COLS).ClearContents
            End If
        End With
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)

    On Error Resume Next
    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, [WeekStartDate]) Is Nothing Then
        [WeekStartDate].Worksheet.Name = Format([WeekStartDate], "m 月 d 日 ;@")
    End If

End Sub

Public Sub CellRoundRobin(rTarget As Range, rValidRange As Range, Cancel As Boolean)

    On Error Resume Next
    
    If rTarget.Cells.Count > 1 Then Exit Sub
    If Intersect(rTarget, rValidRange) Is Nothing Then Exit Sub
    If Len(rTarget.Offset(, 2)) = 0 Then Exit Sub
    
    If Len(rTarget) Then
        rTarget = vbNullString
    Else
        rTarget = 1
    End If
    
    Cancel = True

End Sub