週間スケジュールをExcelで作るときに作った関数たち

週間予定表を1年分作るのに手間がかかるので作った関数たち
汎用的なのはWeekNoToDateぐらいです

やったこと

最初のシートの名前を「Weekly(1)」で作る
週数を表示するセル（ex.B1セル)には式「=SheetNameToNum(GetSheetName(Cell("filename",A1)))」
↑これでそのセルにシート名のカッコの中の数字が入る
月曜日の日付を入れるセル(Ex.C4セル)には式「＝WeekNoToDate(年,B1)」
↑これで第１週目の月曜日の日付が入る
火曜日の日付を入れるセル(Ex.D4セル)には式「=C4+1」
↑これで火曜日の日付が入る
あとは、水木金。。とセルを並べて第１週のシートが完成

あとは、「Weekly(1)」をコピーすると勝手に「Weekly(2)」、「Weekly(3)」と連番がついていく。式もそのままコピーされるので、結果「Weekly(2)」は第２週、「Weekly(3)」は第３週になるので、あとは年末になるまでコピーを繰り返せば完成

最後に、全部のシートの式を消して作業完了
（素人に配る関係で、シート名を変えられてしまうとおかしくなってしまうので）

Option Explicit

' 週数から最初の日付を取得する（月曜はじまり）
Function WeekNoToDate(Y As Integer, W As Integer) As Date

    Application.Volatile True
    
    Dim Gantan As Date
    Gantan = DateSerial(Y, 1, 1)

    WeekNoToDate = Gantan - Weekday(Gantan, vbMonday) + (W - 1) * 7 + 1
    
End Function

' 独自仕様なのでベタ書き。。
Function SheetNameToNum(SheetName As String) As Integer
    Application.Volatile True
    
    Dim sName As String
    sName = SheetName
    sName = Replace(UCase(sName), "WEEKLY(", "")
    sName = Replace(UCase(sName), ")", "")
    sName = Replace(UCase(sName), " ", "")
    sName = Replace(UCase(sName), "　", "")
    
    SheetNameToNum = Val(sName)
    
End Function

' ワークシート関数 CELLで取得したFileNameを引数で渡す
Function GetSheetName(fName As String) As String
    GetSheetName = Right(fName, Len(fName) - InStr(fName, "]"))
End Function

Sub ConValAllSheet()
    Dim S As Worksheet
    For Each S In ThisWorkbook.Worksheets
        S.Activate
        ConvVal
    Next
End Sub

' 式を消す（範囲はベタ書き）
Sub ConvVal()
    Range("A1:I3").Select
    Selection.Value = Selection.Value
    Range("A1").Select
End Sub

' シートをコピーする
Sub CopySheet()
    Worksheets("Weekly(1)").Copy After:=Worksheets(Worksheets.Count)
End Sub

' 今日の週を開く
Sub GoToday()
    Dim WeekNo As Integer
    WeekNo = DatePart("ww", Now(), vbMonday)
    
    On Error GoTo Fin
    ThisWorkbook.Worksheets("Weekly(" & Trim(Str(WeekNo)) & ")").Activate
    FitWindow
    Dim WeekN As Integer
    WeekN = Weekday(Now(), vbMonday)
    ActiveSheet.Range("C5").Offset(rowOffset:=0, columnOffset:=WeekN - 1).Select
    
Fin:
    On Error GoTo 0
End Sub

Sub GoNextWeek()
    Dim WeekNo As Integer
    WeekNo = SheetNameToNum(ActiveSheet.Name) + 1
    
    On Error GoTo Fin
    ThisWorkbook.Worksheets("Weekly(" & Trim(Str(WeekNo)) & ")").Activate
    FitWindow
    ActiveSheet.Range("C5").Select
Fin:
    On Error GoTo 0
End Sub

Sub GoPrevWeek()
    Dim WeekNo As Integer
    WeekNo = SheetNameToNum(ActiveSheet.Name) - 1
    
    On Error GoTo Fin
    ThisWorkbook.Worksheets("Weekly(" & Trim(Str(WeekNo)) & ")").Activate
    FitWindow
    ActiveSheet.Range("C5").Select
Fin:
    On Error GoTo 0
End Sub

Sub FitWindow()
    ActiveSheet.Range("A:I").Select
    ActiveWindow.Zoom = True
End Sub

Sub MakeFixSchedule()
    MakeScheduleCell RGB(176, 224, 230) ' 予定（変更不可）
End Sub

Sub MakeVarSchedule()
    MakeScheduleCell RGB(250, 250, 210) ' 予定（変更化）
End Sub

Sub MakeHolSchedule()
    MakeScheduleCell RGB(255, 228, 225) ' 予定（休暇など）
End Sub

Sub MakeScheduleCell(cellcolor As Long)
    Dim rng As Range
    Set rng = Selection
    rng.Merge
    rng.Interior.Color = cellcolor
End Sub

Sub RemoveScheduleCell()
    Dim rng As Range
    Set rng = Selection
    rng.Interior.ColorIndex = 0 ' 塗りつぶしなし
    rng.UnMerge
    rng.Item(1).Value = ""
    rng.Item(1).Select
    Set rng = Nothing
End Sub