【VBA】週間のカレンダーを作成【祝日の反映、データの取得、データ書き込みをする】

Sub MakeCal()
  
  Range("A5").Resize(3, 8).ClearContents '入力をクリア
  
  Range("A5") = "曜日"
  Range("A6") = "日付"
  
  Dim A
  A = Array("日", "月", "火", "水", "木", "金", "土")
  Range("B5").Resize(1, 7) = A '曜日を入力
  
  Dim B
  B = DateSerial(Range("A2"), Range("A3"), 1) '指定月の1日
  Range("B6") = B - (Weekday(B) - 1) + (Range("A4") - 1) * 7 '指定週の日曜日の日付
  Range("C6:H6") = "=B6+1" '月～土の日付を入力
  Range("C6:H6").Value = Range("C6:H6").Value '値に変換
  
End Sub

Sub SetFormat()
  
  '日曜日の背景色
  Range("B5").Resize(3).Interior.Color = RGB(252, 228, 214)
  '土曜日の背景色
  Range("H5").Resize(3).Interior.Color = RGB(221, 235, 247)
  '平日の背景色
  Range("C5").Resize(3, 5).Interior.Color = xlNone
  '罫線
  Range("A5").Resize(3, 8).Borders.LineStyle = xlContinuous
  '表示形式
  Range("B6:H6").NumberFormatLocal = "m/d"
  
End Sub

Sub GetHoliday()
  
  Dim A, B
  With Sheets("週")
    A = .Range("B6") '指定週の日曜日
    B = .Range("H6") '指定週の土曜日
  End With
  
  '週でフィルタ
  With Sheets("祝日")
    .Range("A1").AutoFilter 3, ">=" & A, xlAnd, "<=" & B
    .Range("A1").CurrentRegion.Copy .Range("E1") '結果をコピー
    .Range("A1").AutoFilter 'フィルタ解除
  End With
  
  '祝日を取得
  For i = 2 To Sheets("祝日").Cells(Rows.Count, "G").End(xlUp).Row
    With Sheets("週").Range("A6").Offset(0, Weekday(Sheets("祝日").Cells(i, "G"))) '日付の位置を取得
      .NumberFormatLocal = "m/d(" & Sheets("祝日").Cells(i, "F") & ")" '表示形式を設定
      .Offset(-1, 0).Resize(3).Interior.Color = RGB(252, 228, 214) '背景色を設定
    End With
  Next
  
  Sheets("祝日").Range("E1").CurrentRegion.ClearContents 'フィルタ結果をクリア
  
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  
  If Intersect(Range("A2:A4"), Target) Is Nothing Then Exit Sub
  
  Application.ScreenUpdating = False
  
  Call MakeCal 'カレンダーを作成
  Call SetFormat '書式を設定
  Call GetHoliday '祝日を設定
    
  Application.ScreenUpdating = True
    
End Sub

Sub NextWeek()
  
  Range("A4") = Range("A4") + 1 '1週進める
  
  Dim A
  A = Range("H6") '土曜日の日付を取得
  B = DateSerial(Year(A), Month(A), 1) '「1日」の日付を取得
  
  Range("A2") = Year(A) '年
  Range("A3") = Month(A) '月
  Range("A4") = DateDiff("ww", B, A) + 1 '週
    
End Sub

Sub PreWeek()
  
  Range("A4") = Range("A4") - 1
  
  Dim A
  A = Range("H6") '土曜日の日付を取得
  B = DateSerial(Year(A), Month(A), 1) '「1日」の日付を取得
  
  Range("A2") = Year(A) '年
  Range("A3") = Month(A) '月
  Range("A4") = DateDiff("ww", B, A) + 1 '週
    
End Sub

Sub ThisWeek()
  
  Range("A2") = Year(Date) '今年を取得
  Range("A3") = Month(Date) '今月を取得
  '週を取得
  Range("A4") = DateDiff("ww", DateSerial(Year(Date), Month(Date), 1), Date) + 1
  
End Sub

Sub GetData()
  
  Dim A, B
  With Sheets("週")
    A = .Range("B6") '週初めの日付
    B = .Range("H6") '週末の日付
  End With
  
  '週でフィルタ
  With Sheets("DB")
    .Range("A1").AutoFilter 1, ">=" & A, xlAnd, "<=" & B
    .Range("A1").CurrentRegion.Copy .Range("D1")
    .Range("A1").AutoFilter
  End With
  
  'データを取得
  For i = 2 To Sheets("DB").Cells(Rows.Count, "D").End(xlUp).Row
    With Sheets("週").Range("A7")
      .Offset(0, Weekday(Sheets("DB").Cells(i, "D"))) = Sheets("DB").Cells(i, "E")
    End With
  Next
  
  Sheets("DB").Range("D1").CurrentRegion.ClearContents 'フィルタ結果をクリア
         
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  
  If Intersect(Range("A2:A4"), Target) Is Nothing Then Exit Sub
  
  Application.ScreenUpdating = False
  
  Call MakeCal 'カレンダーを作成
  Call SetFormat '書式を設定
  Call GetHoliday '祝日を設定
  Call GetData 'データを取得
    
  Application.ScreenUpdating = True
    
End Sub

Sub WriteData()
      
  Dim A
  For Each A In Sheets("週").Range("B6:H6")
    Sheets("DB").Range("A1").AutoFilter 1, Format(A, "yyyy/m/d") '日付でフィルタ
    'データが登録済み
    If Application.Subtotal(103, Sheets("DB").Range("A:A")) > 1 Then
      Sheets("DB").Cells(Rows.Count, "A").End(xlUp).Offset(0, 1) = A.Offset(1, 0)
    Else 'データが未登録
      If A.Offset(1, 0) <> "" Then '値が入力されている
        Sheets("DB").Range("A1").AutoFilter 1 'フィルタ解除
        With Sheets("DB").Cells(Rows.Count, "A").End(xlUp) '最終行
          .Offset(1, 0) = A '日付を入力
          .Offset(1, 1) = A.Offset(1, 0) '値を入力
        End With
      End If
    End If
  Next
  Sheets("DB").Range("A1").AutoFilter 'フィルタを解除
    
End Sub

Sub WriteData()
      
  Dim A
  For Each A In Sheets("週").Range("B6:H6")
    Sheets("DB").Range("A1").AutoFilter 1, Format(A, "yyyy/m/d") '日付でフィルタ
    'データが登録済み
    If Application.Subtotal(103, Sheets("DB").Range("A:A")) > 1 Then
      Sheets("DB").Cells(Rows.Count, "A").End(xlUp).Offset(0, 1) = A.Offset(1, 0)
    Else 'データが未登録
      If A.Offset(1, 0) <> "" Then '値が入力されている
        Sheets("DB").Range("A1").AutoFilter 1 'フィルタ解除
        With Sheets("DB").Cells(Rows.Count, "A").End(xlUp) '最終行
          .Offset(1, 0) = A '日付を入力
          .Offset(1, 1) = A.Offset(1, 0) '値を入力
        End With
      End If
    End If
  Next
  Sheets("DB").Range("A1").AutoFilter 'フィルタを解除
    
End Sub

Sub WriteData()
      
  Dim A
  For Each A In Sheets("週").Range("B6:H6")
    Sheets("DB").Range("A1").AutoFilter 1, Format(A, "yyyy/m/d") '日付でフィルタ
    'データが登録済み
    If Application.Subtotal(103, Sheets("DB").Range("A:A")) > 1 Then
      Sheets("DB").Cells(Rows.Count, "A").End(xlUp).Offset(0, 1) = A.Offset(1, 0)
    Else 'データが未登録
      If A.Offset(1, 0) <> "" Then '値が入力されている
        Sheets("DB").Range("A1").AutoFilter 1 'フィルタ解除
        With Sheets("DB").Cells(Rows.Count, "A").End(xlUp) '最終行
          .Offset(1, 0) = A '日付を入力
          .Offset(1, 1) = A.Offset(1, 0) '値を入力
        End With
      End If
    End If
  Next
  Sheets("DB").Range("A1").AutoFilter 'フィルタを解除
    
End Sub