'v3
Function СУММЕСЛИДРОБЬ(диапазон_суммирования As Range, диапазон_условия As Range, условие As Variant) As String
    Const delimeter = "/"
    
    Dim aSumm As Variant, aCond As Variant
    aSumm = диапазон_суммирования.Value
    aCond = диапазон_условия.Resize(диапазон_суммирования.Rows.Count, диапазон_суммирования.Columns.Count).Value
    
    Dim ya As Long, xa As Long, xb As Long, arr As Variant, brr As Variant
    For ya = 1 To UBound(aSumm, 1)
        For xa = 1 To UBound(aSumm, 2)
            If aCond(ya, xa) = условие Then
                arr = Split(aSumm(ya, xa), delimeter)
                If IsEmpty(brr) Then
                    ReDim brr(LBound(arr) To UBound(arr))
                ElseIf UBound(arr) > UBound(brr) Then
                    ReDim Preserve brr(LBound(brr) To UBound(arr))
                End If
                For xb = LBound(arr) To UBound(arr)
                    If IsNumeric(arr(xb)) Then
                        brr(xb) = CLng(brr(xb)) + CLng(arr(xb))
                    End If
                Next
            End If
        Next
    Next
    СУММЕСЛИДРОБЬ = Join(brr, delimeter)
End Function

Option Explicit
'v2
Function СУММЕСЛИДРОБЬ(диапазон_суммирования As Range, диапазон_условия As Range, условие As Variant) As String
    Const delimeter = "/"
    
    Dim aSumm As Variant, aCond As Variant
    aSumm = диапазон_суммирования.Value
    aCond = диапазон_условия.Resize(диапазон_суммирования.Rows.Count).Value
    
    Dim ya As Long, xb As Long, arr As Variant, brr As Variant
    For ya = 1 To UBound(aSumm, 1)
        If aCond(ya, 1) = условие Then
            arr = Split(aSumm(ya, 1), delimeter)
            If IsEmpty(brr) Then
                ReDim brr(LBound(arr) To UBound(arr))
            ElseIf UBound(arr) > UBound(brr) Then
                ReDim Preserve brr(LBound(brr) To UBound(arr))
            End If
            For xb = LBound(arr) To UBound(arr)
                If IsNumeric(arr(xb)) Then
                    brr(xb) = CLng(brr(xb)) + CLng(arr(xb))
                End If
            Next
        End If
    Next
    СУММЕСЛИДРОБЬ = Join(brr, delimeter)
End Function

=ЕСЛИОШИБКА(ЗНАЧЕН(СЖПРОБЕЛЫ(ПСТР(ПОДСТАВИТЬ($D4;"/";ПОВТОР(" ";10));10*(СТОЛБЕЦ(A:A)-1)+1;10)));0)

=СУММЕСЛИМН($O$4:$O$24;$A$4:$A$24;$A29)&"/"&СУММЕСЛИМН($P$4:$P$24;$A$4:$A$24;$A29)

Option Explicit
Public fso As Object
'v5
Sub Обновить_связи()
    Dim openedBooks As Object
    Set openedBooks = GetOpenedBooks()
    
    Dim doneBooks As Object
    Set doneBooks = CreateObject("Scripting.Dictionary")
    
'    Application.ScreenUpdating = False
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    OpenLinkSources ActiveWorkbook, doneBooks
    Application.Calculate
    CloseJustOpenedBooks openedBooks
    
    Application.Calculation = Application_Calculation
'    Application.ScreenUpdating = True
    
    MsgBox "Обновлены файлы:" & vbCrLf & vbCrLf & Join(doneBooks.Items(), vbCrLf), vbInformation, "Связи"
End Sub

Private Sub OpenLinkSources(wbInit As Workbook, doneBooks As Object)
    On Error Resume Next
    doneBooks(wbInit.FullName) = ""
    doneBooks(wbInit.FullName) = wbInit.Name
    On Error GoTo 0
    Dim vLink As Variant, aLink As Variant, wbSource As Workbook
    aLink = wbInit.LinkSources(xlExcelLinks)
    If Not IsEmpty(aLink) Then
        For Each vLink In aLink
            If Not doneBooks.Exists(vLink) Then
                Set wbSource = GetWb(vLink)
                OpenLinkSources wbSource, doneBooks
            End If
        Next
    End If
End Sub

Private Function GetWb(ByVal sFull As String) As Workbook
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sFull)
    On Error GoTo 0
    If Not wb Is Nothing Then
        Set GetWb = wb
        Exit Function
    End If
    
    If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FileExists(sFull) Then Exit Function
    Dim sName As String
    sName = fso.GetFileName(sFull)
    
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If LCase(wb.FullName) <> LCase(sFull) Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, False)
    End If
    
    Set GetWb = wb
End Function

Private Function GetOpenedBooks() As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        dic(wb.FullName) = Empty
    Next
    
    Set GetOpenedBooks = dic
End Function

Private Sub CloseJustOpenedBooks(openedBooks As Object)
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If Not openedBooks.Exists(wb.FullName) Then
            If Not wb.ReadOnly Then wb.Save
            wb.Close False
        End If
    Next
End Sub

Option Explicit
Public fso As Object
'v3
Sub Обновить_связи()
    Dim openedBooks As Object
    Set openedBooks = GetOpenedBooks()
    
    Dim doneBooks As Object
    Set doneBooks = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    OpenLinkSources ActiveWorkbook, doneBooks
    Application.Calculate
    CloseJustOpenedBooks openedBooks
    
    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
    
    MsgBox "Обновлены файлы:" & vbCrLf & vbCrLf & Join(doneBooks.Items(), vbCrLf), vbInformation, "Связи"
End Sub

Private Sub OpenLinkSources(wbInit As Workbook, doneBooks As Object)
    doneBooks(wbInit.FullName) = wbInit.Name
    Dim vLink As Variant, aLink As Variant, wbSource As Workbook
    aLink = wbInit.LinkSources(xlExcelLinks)
    If Not IsEmpty(aLink) Then
        For Each vLink In aLink
            If Not doneBooks.Exists(vLink) Then
                Set wbSource = GetWb(vLink)
                OpenLinkSources wbSource, doneBooks
            End If
        Next
    End If
End Sub

Private Function GetWb(ByVal sFull As String) As Workbook
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sFull)
    On Error GoTo 0
    If Not wb Is Nothing Then
        Set GetWb = wb
        Exit Function
    End If
    
    If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FileExists(sFull) Then Exit Function
    Dim sName As String
    sName = fso.GetFileName(sFull)
    
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If LCase(wb.FullName) <> LCase(sFull) Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, False)
    End If
    
    Set GetWb = wb
End Function

Private Function GetOpenedBooks() As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        dic(wb.FullName) = Empty
    Next
    
    Set GetOpenedBooks = dic
End Function

Private Sub CloseJustOpenedBooks(openedBooks As Object)
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If Not openedBooks.Exists(wb.FullName) Then
            wb.Close True
        End If
    Next
End Sub

Option Explicit
Public fso As Object
'v2
Sub Обновить_связи()
    Dim openedBooks As Object
    Set openedBooks = GetOpenedBooks()
    
    Dim doneBooks As Object
    Set doneBooks = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    OpenLinkSources ActiveWorkbook, doneBooks
    Application.Calculate
    CloseJustOpenedBooks openedBooks
    
    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
    
    MsgBox "Обновлены файлы:" & vbCrLf & vbCrLf & Join(doneBooks.Items(), vbCrLf), vbInformation, "Связи"
End Sub

Private Sub OpenLinkSources(wbInit As Workbook, doneBooks As Object)
    doneBooks(wbInit.FullName) = wbInit.Name
    Dim vLink As Variant, aLink As Variant, wbSource As Workbook
    aLink = wbInit.LinkSources(xlExcelLinks)
    If Not IsEmpty(aLink) Then
        For Each vLink In aLink
            If Not doneBooks.Exists(vLink) Then
                Set wbSource = GetWb(vLink)
                OpenLinkSources wbSource, doneBooks
            End If
        Next
    End If
End Sub

Private Function GetWb(ByVal sFull As String) As Workbook
    If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FileExists(sFull) Then Exit Function
    Dim sName As String
    sName = fso.GetFileName(sFull)
    
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If LCase(wb.FullName) <> LCase(sFull) Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, False)
    End If
    
    Set GetWb = wb
End Function

Private Function GetOpenedBooks() As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        dic(wb.FullName) = Empty
    Next
    
    Set GetOpenedBooks = dic
End Function

Private Sub CloseJustOpenedBooks(openedBooks As Object)
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If Not openedBooks.Exists(wb.FullName) Then
            wb.Close True
        End If
    Next
End Sub

Option Explicit
Public fso As Object

Sub Обновить_связи()
    Dim done As Object
    Set done = CreateObject("Scripting.Dictionary")
    OpenLinkSources ActiveWorkbook, done
End Sub

Private Sub OpenLinkSources(wbInit As Workbook, done As Object)
    done(wbInit.FullName) = Empty
    Dim vLink As Variant, aLink As Variant, wbSource As Workbook
    aLink = wbInit.LinkSources(xlExcelLinks)
    If Not IsEmpty(aLink) Then
        For Each vLink In aLink
            If Not done.Exists(vLink) Then
                Set wbSource = GetWb(vLink)
                OpenLinkSources wbSource, done
            End If
        Next
    End If
End Sub

Private Function GetWb(ByVal sFull As String) As Workbook
    If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FileExists(sFull) Then Exit Function
    Dim sName As String
    sName = fso.GetFileName(sFull)
    
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If LCase(wb.FullName) <> LCase(sFull) Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull)
    End If
    
    Set GetWb = wb
End Function

=СМЕЩ(Лист1!$A$1;2;ПОИСКПОЗ(F4;Лист1!$1:$1;0)-1;СЧЁТЗ(СМЕЩ(Лист1!$A$1;2;ПОИСКПОЗ(F4;Лист1!$1:$1;0)-1;100000;1));1)

=СМЕЩ(Лист1!$A$1;2;ПОИСКПОЗ(F3;Лист1!$1:$1;0)-1;100;1)

Option Explicit

Private Sub Worksheet_Activate()
    Заполнить_смены SourceRange:=Sheets("Смены").Range("A1"), targetRange:=ActiveSheet.Range("область_данных")
End Sub

Sub Заполнить_смены(SourceRange As Range, targetRange As Range)
    Set SourceRange = SourceRange.CurrentRegion
    Set targetRange = Intersect(targetRange, targetRange.Parent.UsedRange)
    
    Dim dicSmen As Object
    Set dicSmen = GetSmenDic(SourceRange)
    
    Dim yName As Object
    Set yName = GetNamesYdic(targetRange.Columns(1), dicSmen)
    
    Dim xDate As Object
    Set xDate = GetDateXdic(targetRange.Rows(1), dicSmen)
    
    Dim aTarg As Variant
    aTarg = InitTargetArray(yName, xDate)
    FillTargetArray aTarg, yName, xDate, dicSmen
    
    Set targetRange = targetRange.Cells(LBound(aTarg, 1), LBound(aTarg, 2))
    Set targetRange = targetRange.Resize(UBound(aTarg, 1) - LBound(aTarg, 1) + 1)
    Set targetRange = targetRange.Resize(, UBound(aTarg, 2) - LBound(aTarg, 2) + 1)
    targetRange.Value = aTarg
End Sub
    
Private Sub FillTargetArray(aTarg As Variant, yName As Object, xDate As Object, dicSmen As Object)
    Dim dicName As Object
    Dim dd As Variant, xt As Long
    Dim nn As Variant, yt As Long
    For Each dd In dicSmen.Keys
        xt = xDate(dd)
        Set dicName = dicSmen(dd)
        For Each nn In dicName.Keys
            yt = yName(nn)
            aTarg(yt, xt) = TranslateTabel(dicName(nn))
        Next
    Next
End Sub

Private Function TranslateTabel(sSource As String) As String
    TranslateTabel = Left(sSource, 1)
End Function

Private Function InitTargetArray(yName As Object, xDate As Object) As Variant
    Dim aTarg As Variant, iMin As Long, iMax As Long
    Dim vv As Variant
    For Each vv In yName.Items
        If iMax < vv Then
            iMax = vv
        End If
        If iMin = 0 Then
            iMin = vv
        ElseIf iMin > vv Then
            iMin = vv
        End If
    Next
    ReDim aTarg(iMin To iMax)
    
    iMax = 0
    iMin = 0
    For Each vv In xDate.Items
        If iMax < vv Then
            iMax = vv
        End If
        If iMin = 0 Then
            iMin = vv
        ElseIf iMin > vv Then
            iMin = vv
        End If
    Next
    ReDim aTarg(LBound(aTarg) To UBound(aTarg), iMin To iMax)
    
    InitTargetArray = aTarg
End Function
    
Private Function GetDateXdic(targetRange As Range, dicSmen As Object) As Object
    Dim aDate As Variant
    aDate = targetRange.Value
    ClearArray aDate
    
    Dim dicDate As Object
    Set dicDate = CreateObject("Scripting.Dictionary")
    Dim dd As Variant
    For Each dd In dicSmen.Keys
        dicDate(dd) = 0
    Next
    
    Dim xa As Long, xm As Long
    For xa = UBound(aDate, 2) To 1 Step -1
        If dicDate.Exists(aDate(1, xa)) Then
            dicDate(aDate(1, xa)) = xa
        End If
    Next
    xm = UBound(aDate, 2)
    For Each dd In dicDate.Keys
        If dicDate(dd) = 0 Then
            xm = xm + 1
            dicDate(dd) = xm
            targetRange.Cells(1, xm).Value = dd
        End If
    Next
    Set GetDateXdic = dicDate
End Function
    
Private Function GetNamesYdic(targetRange As Range, dicSmen As Object) As Object
    Dim aName As Variant
    aName = targetRange.Value
    ClearArray aName
    
    Dim dicName As Object
    Set dicName = CreateObject("Scripting.Dictionary")
    Dim dd As Variant, nn As Variant
    For Each dd In dicSmen.Items
        For Each nn In dd.Keys
            dicName(nn) = 0
        Next
    Next
    
    Dim ya As Long, ym As Long
    For ya = UBound(aName, 1) To 1 Step -1
        If dicName.Exists(aName(ya, 1)) Then
            dicName(aName(ya, 1)) = ya
            If ym < ya Then ym = ya
        End If
    Next
    For Each nn In dicName.Keys
        If dicName(nn) = 0 Then
            ym = ym + 1
            dicName(nn) = ym
            targetRange.Cells(ym, 1).Value = nn
        End If
    Next
    Set GetNamesYdic = dicName
End Function

Private Function GetSmenDic(SourceRange As Range) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim arr As Variant
    arr = SourceRange.Value
    ClearArray arr
    
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        If Not IsEmpty(arr(ya, 1)) Then
            If IsDate(arr(ya, 1)) Then
                If Not dic.Exists(arr(ya, 1)) Then
                    Set dic(arr(ya, 1)) = CreateObject("Scripting.Dictionary")
                End If
            End If
        End If
    Next
    
    Dim xa As Long, xt As Long
    For xa = UBound(arr, 2) To 2 Step -1
        If arr(1, xa) = "Тип работы" Then
            xt = xa
            Exit For
        End If
    Next
    If xt = 0 Then xt = UBound(arr, 2)
    
    For xa = 2 To xt - 1
        If arr(1, xa) Like "Работник*" Then
            For ya = 2 To UBound(arr, 1) 'To 2 Step -1
                If dic.Exists(arr(ya, 1)) Then
                    If Not dic(arr(ya, 1)).Exists(arr(ya, xa)) Then
                        Set dic(arr(ya, 1))(arr(ya, xa)) = CreateObject("Scripting.Dictionary")
                    End If
                    dic(arr(ya, 1))(arr(ya, xa)) = arr(ya, xt)
                End If
            Next
        End If
    Next
    
    Set GetSmenDic = dic
End Function

Private Sub ClearArray(arr As Variant)
    Dim ya As Long
    Dim xa As Long
    For ya = LBound(arr, 1) To UBound(arr, 1)
        For xa = LBound(arr, 2) To UBound(arr, 2)
            If IsError(arr(ya, xa)) Then
                arr(ya, xa) = Empty
            End If
        Next
    Next
End Sub

=ЕСЛИ((СЧЁТЕСЛИМН(Смены!$B:$B;$A19;Смены!$A:$A;B$17;Смены!$E:$E;"Работа")
+СЧЁТЕСЛИМН(Смены!$C:$C;$A19;Смены!$A:$A;B$17;Смены!$E:$E;"Работа")
+СЧЁТЕСЛИМН(Смены!$D:$D;$A19;Смены!$A:$A;B$17;Смены!$E:$E;"Работа"))>0;"Р";
ЕСЛИ((СЧЁТЕСЛИМН(Смены!$B:$B;$A19;Смены!$A:$A;B$17;Смены!$E:$E;"Дорога")
+СЧЁТЕСЛИМН(Смены!$C:$C;$A19;Смены!$A:$A;B$17;Смены!$E:$E;"Дорога")
+СЧЁТЕСЛИМН(Смены!$D:$D;$A19;Смены!$A:$A;B$17;Смены!$E:$E;"Дорога"))>0;"Д";
ЕСЛИ((СЧЁТЕСЛИМН(Смены!$B:$B;$A19;Смены!$A:$A;B$17;Смены!$E:$E;"Выходной")
+СЧЁТЕСЛИМН(Смены!$C:$C;$A19;Смены!$A:$A;B$17;Смены!$E:$E;"Выходной")
+СЧЁТЕСЛИМН(Смены!$D:$D;$A19;Смены!$A:$A;B$17;Смены!$E:$E;"Выходной"))>0;"В";"бланил")))

Option Explicit

Sub Сумм_диапазон()
    Dim rSource As Range
    On Error Resume Next
    Set rSource = Application.InputBox("Выберите диапазон-источник", "Суммирование", Default:="1:9", Type:=8)
    Set rSource = Intersect(rSource, rSource.Parent.UsedRange)
    On Error GoTo 0
    If rSource Is Nothing Then Exit Sub
    
    Dim aSor As Variant
    aSor = rSource.Value
    ClearArray aSor
    
    Dim aTar As Variant, dic As Object
    aTar = GetTargetArray(aSor, dic)
    If IsEmpty(aTar) Then Exit Sub
    FillTargetArray aTar, aSor, dic, rSource
    
    Dim rTarget As Range
    On Error Resume Next
    Set rTarget = Application.InputBox("Выберите диапазон-приёмник", "Суммирование", Default:="O17", Type:=8)
    Set rTarget = Intersect(rTarget, rSource.Parent.UsedRange)
    On Error GoTo 0
    If rTarget Is Nothing Then Exit Sub
    
    PrintArray rTarget, aTar
End Sub

Private Sub PrintArray(rTarget As Range, aTar As Variant)
    Set rTarget = rTarget.Resize(UBound(aTar, 1), UBound(aTar, 2))
    
    rTarget.Formula = aTar
End Sub

Private Sub FillTargetArray(aTar As Variant, aSor As Variant, dic As Object, rSor As Range)
    Dim ys As Long, xs As Long, xt As Long, yt As Long
    For xs = 1 To UBound(aSor, 2)
        If IsDate(aSor(1, xs)) Then
            If aSor(1, xs) > 0 Then
                For xt = 2 To UBound(aTar, 2) - 1
                    If aSor(1, xs) >= aTar(1, xt) Then Exit For
                Next
                For ys = 2 To UBound(aSor, 1)
                    If aSor(ys, xs) <> 0 Then
                        yt = dic(aSor(ys, 1)) + 2
                        aTar(yt, xt) = aTar(yt, xt) & rSor.Cells(ys, xs).Address(0, 0) & " "
                    End If
                Next
            End If
        End If
    Next
    Dim ss As String
    For yt = 2 To UBound(aTar, 1)
        For xt = 2 To UBound(aTar, 2)
            If Not IsEmpty(aTar(yt, xt)) Then
                ss = aTar(yt, xt)
                ss = Trim(ss)
                ss = Replace(ss, " ", "+")
                ss = "=" & ss
                aTar(yt, xt) = ss
            End If
        Next
    Next
End Sub

Private Function GetTargetArray(aSor As Variant, dic As Object) As Variant
    Dim xs As Long, dtMin As Date, dtMax As Date
    For xs = 1 To UBound(aSor, 2)
        If IsDate(aSor(1, xs)) Then
            If aSor(1, xs) > 0 Then
                If dtMax < aSor(1, xs) Then
                    dtMax = aSor(1, xs)
                End If
                If dtMin = 0 Then
                    dtMin = aSor(1, xs)
                ElseIf dtMin > aSor(1, xs) Then
                    dtMin = aSor(1, xs)
                End If
            End If
        End If
    Next
    If dtMax = 0 Then Exit Function
    If dtMin = 0 Then Exit Function
    
    dtMin = DateSerial(Year(dtMin), Month(dtMin), 1)
    dtMax = DateSerial(Year(dtMax), Month(dtMax), 1)
    
    Dim dtCur As Long
    xs = 0
    dtCur = dtMin
    Do
        xs = xs + 1
        If dtCur = dtMax Then Exit Do
        dtCur = DateSerial(Year(dtCur), Month(dtMin) + 1, 1)
        DoEvents
    Loop
    
    Dim aTarg As Variant
    ReDim aTarg(1 To 1 + xs)
    
    Set dic = CreateObject("Scripting.Dictionary")
    Dim ys As Long
    For xs = 1 To UBound(aSor, 2)
        If IsDate(aSor(1, xs)) Then
            If aSor(1, xs) > 0 Then
                For ys = 2 To UBound(aSor, 1)
                    If aSor(ys, xs) <> 0 Then
                        If Not dic.Exists(aSor(ys, 1)) Then
                            dic(aSor(ys, 1)) = dic.Count
                        End If
                    End If
                Next
            End If
        End If
    Next
    If dic.Count = 0 Then Exit Function
    
    ReDim aTarg(1 To 1 + dic.Count, 1 To UBound(aTarg))
    For ys = 0 To dic.Count - 1
        aTarg(ys + 2, 1) = dic.Keys()(ys)
    Next
    
    dtCur = dtMin
    For xs = 2 To UBound(aTarg, 2)
        aTarg(1, xs) = dtCur
        dtCur = DateSerial(Year(dtCur), Month(dtMin) + 1, 1)
    Next
    GetTargetArray = aTarg
End Function

Private Sub ClearArray(arr As Variant)
    Dim ya As Long
    Dim xa As Long
    For ya = LBound(arr, 1) To UBound(arr, 1)
        For xa = LBound(arr, 2) To UBound(arr, 2)
            If IsError(arr(ya, xa)) Then
                arr(ya, xa) = Empty
            End If
        Next
    Next
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

=ИНДЕКС($E$21:$E$25;СТОЛБЕЦ(A1))*ИНДЕКС($E$14:$E$18;СТОЛБЕЦ(A1))/ИНДЕКС($E$14:$E$18;СТРОКА(A1))

Sub EditHyperlinks()
    Dim gg As Range, hl As Hyperlink
    For Each gg In Intersect(ActiveSheet.UsedRange, Range("G:G")).Cells
        If gg.Hyperlinks.Count > 0 Then
            gg.Hyperlinks(1).TextToDisplay = gg.EntireRow.Columns("K:K").Value
        End If
    Next
End Sub

=ТЕКСТ(A2;"ММММ")

=СЧЁТЕСЛИМН($B:$B;$F3;$C:$C;G$2)

=ПРОМЕЖУТОЧНЫЕ.ИТОГИ(1;СМЕЩ(RC37;-(14-ПОИСКПОЗ("*";RC2:R[13]C2;0));0;13;1))

=ЕСЛИ(RC[1]=0;ПРОМЕЖУТОЧНЫЕ.ИТОГИ(1;СМЕЩ(RC22;-(14-ПОИСКПОЗ("*";RC2:R[13]C2;0));0;13;1));RC[1]*R1C20-RC[-4])

=ЕСЛИ(ЕПУСТО(RC[-18]);RC[2]*R1C20-RC[-3];СУММ(R[1]C:R[13]C))

Option Explicit

Sub DynaComments()
    Dim cl As Range
    For Each cl In Range("B4:E4").Cells
        FillValidation targetCell:=cl.Cells(4, 1), dateCell:=cl, checkColumn1:=Range("G4:G11"), checkColumn2:=Range("H4:H11"), valueColumn:=Range("I4:I11")
    Next
End Sub

Private Sub FillValidation(targetCell As Range, dateCell As Range, checkColumn1 As Range, checkColumn2 As Range, valueColumn As Range)
    Dim arr As Variant
    arr = GetArr(dateCell:=dateCell, checkColumn1:=checkColumn1, checkColumn2:=checkColumn2, valueColumn:=valueColumn)
    
    With targetCell.Validation
        .Delete
        If Not IsEmpty(arr) Then
            .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator:=xlBetween
            .IgnoreBlank = True
            .InCellDropdown = False
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = Join(arr, Chr(10))
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End If
    End With
End Sub

Private Function GetArr(dateCell As Range, checkColumn1 As Range, checkColumn2 As Range, valueColumn As Range) As Variant
    Dim aVal As Variant, aCh1 As Variant, aCh2 As Variant
    aVal = valueColumn.Value
    aCh1 = checkColumn1.Resize(UBound(aVal, 1), 1).Value
    aCh2 = checkColumn2.Resize(UBound(aVal, 1), 1).Value
    
    Dim arr As Variant, ya As Long
    ReDim arr(1 To UBound(aVal, 1))
    ya = LBound(arr) - 1
    
    Dim dt As Variant
    dt = dateCell.Value
    
    Dim yv As Long
    For yv = 1 To UBound(aVal, 1)
        If aCh1(yv, 1) = dt Then
            GoTo fillRow
        ElseIf aCh2(yv, 1) = dt Then
            GoTo fillRow
        End If
        GoTo skipRow
fillRow:
        ya = ya + 1
        arr(ya) = aVal(yv, 1)
skipRow:
    Next
    If ya < LBound(arr) Then Exit Function
    ReDim Preserve arr(LBound(arr) To ya)
    
    GetArr = arr
End Function

=ЕСЛИ(ИЛИ($G4=B$4;$H4=B$4;);$I4&" ";"")&J5

=СЖПРОБЕЛЫ(J4)

Option Explicit

Sub Собрать()
    CloseEmptyWb
    Dim wbSource As Workbook
    Set wbSource = ActiveWorkbook
    
    Dim wbTarget As Workbook
    Set wbTarget = Workbooks.Add(1)
    
    Dim sh As Worksheet
    For Each sh In wbSource.Worksheets
        If sh.Range("B1").Value = "Дата" Then
            CopySheet sh, wbTarget.Sheets(1)
        End If
    Next
    
    MakeSumSheet wbTarget
    
    wbTarget.Saved = True
End Sub

Private Sub MakeSumSheet(wb As Workbook)
    wb.Sheets(1).Copy After:=wb.Sheets(1)
    Dim sh As Worksheet
    Set sh = wb.Sheets(2)
    With sh.Sort
        .SortFields.Clear
        .SortFields.Add Key:=sh.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange sh.UsedRange
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Dim ya As Long
    For ya = 2 To sh.UsedRange.Rows.Count
        If IsNumeric(sh.UsedRange.Cells(ya, 1).Text) Then
            sh.UsedRange.Cells(ya, 1).Value = WorksheetFunction.RoundDown(sh.UsedRange.Cells(ya, 1).Value, 1)
        End If
    Next
    
    sh.Columns(2).Delete
    sh.UsedRange.RemoveDuplicates Columns:=Array(1), Header:=xlYes
    
    Dim arr As Variant
    ReDim arr(1 To 1, 1 To 12)
    For ya = 1 To UBound(arr, 2)
        arr(1, ya) = DateSerial(Year(Date), ya, 1)
    Next
    With sh.Cells(1, 2).Resize(1, UBound(arr, 2))
        .Value = arr
        .NumberFormat = "mmm-yy"
        .Font.Bold = True
    End With
    
    With sh.Cells(2, 2).Resize(sh.UsedRange.Rows.Count - 1, UBound(arr, 2))
        .FormulaR1C1 = "=COUNTIFS('" & wb.Sheets(1).Name & "'!C2,"">=""&R1C,'" & wb.Sheets(1).Name & "'!C2,""<=""&EOMONTH(R1C,0),'" & wb.Sheets(1).Name & "'!C1,"">=""&RC1,'" & wb.Sheets(1).Name & "'!C1,""<""&R[1]C1)"
        .Rows(.Rows.Count).FormulaR1C1 = "=COUNTIFS('" & wb.Sheets(1).Name & "'!C2,"">=""&R1C,'" & wb.Sheets(1).Name & "'!C2,""<=""&EOMONTH(R1C,0),'" & wb.Sheets(1).Name & "'!C1,"">=""&RC1)"
        .HorizontalAlignment = xlCenter
        
        .FormatConditions.Add Type:=xlExpression, Formula1:="=B2=0"
        .FormatConditions(1).SetFirstPriority
        With .FormatConditions(1).Font
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = -4.99893185216834E-02
        End With
        .FormatConditions(1).StopIfTrue = False
    End With
End Sub

Private Sub CopySheet(shSource As Worksheet, shTarget As Worksheet)
    Dim yt As Long
    yt = shTarget.Cells(Rows.Count, 1).End(xlUp).Row
    If yt = 1 Then
        shSource.UsedRange.Copy shTarget.Cells(1, 1)
        shTarget.UsedRange.EntireColumn.AutoFit
    Else
        shSource.UsedRange.Offset(1, 0).Copy shTarget.Cells(yt, 1)
    End If
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub