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

Sub MakeCal()
  
  Range("A4").Resize(14, 7).Clear '入力をクリア
  
  Dim A
  A = Array("日", "月", "火", "水", "木", "金", "土")
  
  Dim B, C, D
  ReDim B(1 To 12, 1 To 7)
  k = 1
  C = DateSerial(Range("A2"), Range("A3"), 1) '指定月の1日
  D = DateSerial(Range("A2"), Range("A3") + 1, 0) '指定月の月末
  For i = C To D
    '日曜日でカウントアップ、1日はカウントアップしない
    If Weekday(i) = 1 And Day(i) <> 1 Then k = k + 2
    B(k, Weekday(i)) = Format(i, "yyyy/m/d") '日付を入力
  Next
  
  Range("A4").Resize(1, 7) = A
  Range("A5").Resize(12, 7) = B
  
End Sub

Sub SetFormat()
  
  '日曜日の背景色
  Range("A4").Resize(13).Interior.Color = RGB(252, 228, 214)
  '土曜日の背景色
  Range("G4").Resize(13).Interior.Color = RGB(221, 235, 247)
  '罫線
  Range("A4").Resize(13, 7).Borders.LineStyle = xlContinuous
  For i = 0 To 5
    '表示形式
    Range("A5:G5").Offset(i * 2, 0).NumberFormatLocal = "d"
  Next
  
End Sub

Sub GetHoliday()
  
  Dim A, B
  With Sheets("月")
    A = DateSerial(.Range("A2"), .Range("A3"), 1) '指定月の1日
    B = DateSerial(.Range("A2"), .Range("A3") + 1, 0) '指定月の月末
  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("A5:G16").Find(Sheets("祝日").Cells(i, "G")) '日付の位置を取得
      .NumberFormatLocal = "d(" & Sheets("祝日").Cells(i, "F") & ")" '表示形式を設定
      .Resize(2).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:A3"), Target) Is Nothing Then Exit Sub
  
  Call MakeCal '曜日と日付を入力
  Call SetFormat '書式を設定
  Call GetHoliday '祝日を取得
  
End Sub

Sub NextMonth()
  
  Dim A
  '1か月進める
  A = DateAdd("m", 1, DateSerial(Range("A2"), Range("A3"), 1))
  Range("A2") = Year(A) '年を取得
  Range("A3") = Month(A) '月を取得
  
End Sub

Sub PreMonth()
  
  Dim A
  '1か月戻す
  A = DateAdd("m", -1, DateSerial(Range("A2"), Range("A3"), 1))
  Range("A2") = Year(A) '年を取得
  Range("A3") = Month(A) '月を取得
  
End Sub

Sub ThisMonth()
  
  Range("A2") = Year(Now()) '今年を取得
  Range("A3") = Month(Now()) '今月を取得
  
End Sub

Sub GetData()
  
  Dim A, B
  With Sheets("月")
    A = DateSerial(.Range("A2"), .Range("A3"), 1) '当月の1日
    B = DateSerial(.Range("A2"), .Range("A3") + 1, 0) '月末
  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("A5:G16").Find(Sheets("DB").Cells(i, "D")) '日付の位置を取得
      .Offset(1, 0) = 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:A3"), Target) Is Nothing Then Exit Sub
  
  Call MakeCal '曜日と日付を入力
  Call SetFormat '書式を設定
  Call GetHoliday '祝日を取得
  Call GetData 'データを取得
  
End Sub

Sub WriteData()
      
  Dim A
  For Each A In Sheets("月").Range("A5:G16")
    If IsDate(A) Then '日付の場合
      If Month(A) = Sheets("月").Range("A3") Then '当月の場合
        
        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
        
      End If
    End If
  Next
  Sheets("DB").Range("A1").AutoFilter 'フィルタを解除
      
End Sub

Sub WriteData()
      
  Dim A
  For Each A In Sheets("月").Range("A5:G16")
    If IsDate(A) Then '日付の場合
      If Month(A) = Sheets("月").Range("A3") Then '当月の場合
        
        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
        
      End If
    End If
  Next
  Sheets("DB").Range("A1").AutoFilter 'フィルタを解除
      
End Sub