Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Cells.CountLarge <> 1 Then Exit Sub
    Dim flag As Boolean
    Dim dt As Date
    dt = Target.Value
                
    If IsDate(Target.Value) Then
        If Year(dt) = Range("M2") Then
            If Not Intersect(Target, Range("C6:Y42")) Is Nothing Then
                If IsDate(Target.Cells(1, 0).Value) Then If Month(Target.Cells(1, 0).Value) = Month(dt) Then flag = True
                If IsDate(Target.Cells(1, 2).Value) Then If Month(Target.Cells(1, 2).Value) = Month(dt) Then flag = True
            End If
            If flag = False Then
                If Not Intersect(Target, Range("AI4:AI42")) Is Nothing Then flag = True
            End If
        End If
    End If
    
    If flag Then
        Application.ScreenUpdating = False
        Range("AD2").Value = dt
        Dim ys As Long
        ys = dt - DateSerial(Year(dt), 1, 1) + 2
        Dim arr As Variant
        arr = GetDayArr(ys)
        Application.EnableEvents = False
        Range("AD4").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
        Application.EnableEvents = True
        arr = Empty
        Application.ScreenUpdating = True
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim dt As Date, ys As Long
    dt = Range("AD2").Value
    ys = dt - DateSerial(Year(dt), 1, 1) + 2
    
    Dim rr As Range, needUpdateVypol As Boolean
    Set rr = Range("AD4:AD42")
    Dim cl As Range
    If Not Intersect(Target, rr) Is Nothing Then
        For Each cl In Intersect(Target, rr).Cells
            Sheets("События").Cells(ys, cl.Row - 2).Value = cl.Value
        Next
        needUpdateVypol = True
    End If
    Set rr = rr.Columns(2)
    If Not Intersect(Target, rr) Is Nothing Then
        For Each cl In Intersect(Target, rr).Cells
            Sheets("Статус").Cells(ys, cl.Row - 2).Value = cl.Value
        Next
        needUpdateVypol = True
    End If
    If needUpdateVypol Then
        UpdateVypol
    End If
End Sub

Private Function GetDayArr(ys As Long) As Variant
    Dim rr As Range, rp As Range
    Set rr = Sheets("События").Cells(ys, 2).Resize(, 39)
    Set rp = Sheets("Статус").Cells(ys, 2).Resize(, 39)
    
    GetDayArr = myTranspose(rr, rp)
End Function

Private Function myTranspose(rr As Range, rt As Range) As Variant
    Dim arr As Variant, brr As Variant, trr As Variant
    arr = rr.Value
    trr = rt.Value
    ReDim brr(1 To UBound(arr, 2), 1 To 2)
    Dim xa As Long
    For xa = 1 To UBound(arr, 2)
        brr(xa, 1) = arr(1, xa)
        brr(xa, 2) = trr(1, xa)
    Next
        
    myTranspose = brr
End Function

Private Sub UpdateVypol()
    Dim rr As Range, rp As Range
    Set rr = Sheets("События").Cells(2, 1).Resize(366, 39)
    Set rp = Sheets("Статус").Cells(2, 1).Resize(366, 39)
    
    Dim arr As Variant, prr As Variant
    arr = rr.Value
    prr = rp.Value
    
    Dim rv As Range
    Set rv = Range("AI4:AJ42")
    Dim vrr As Variant
    ReDim vrr(1 To rv.Rows.Count, 1 To rv.Columns.Count)
    
    Dim ya As Long, xa As Long, yv As Long
    For ya = 1 To UBound(arr, 1)
        For xa = 2 To UBound(arr, 2)
            If Not IsEmpty(arr(ya, xa)) Then
                If IsEmpty(prr(ya, xa)) Then
                    yv = yv + 1
                    If yv > UBound(vrr, 1) Then GoTo exitFor
                    vrr(yv, 1) = arr(ya, 1)
                    vrr(yv, 2) = arr(ya, xa)
                End If
            End If
        Next
    Next
exitFor:
    rv.Value = vrr
End Sub