=ЕСЛИ(ЕПУСТО(A2);"";ЕСЛИ(ЛЕВСИМВ(A2;ДЛСТР("Дело "))="Дело ";" К/7";" К/2"))

=ЕСЛИ(ЕПУСТО(A2);"";ЕСЛИ(СЧЁТЕСЛИМН(A2;"Дело *")=1;" К/7";" К/2"))

=СУММЕСЛИМН(OW;ГР;C4;СО;B4;НР;A4;УП;F4;МУ;D4;КЗ;E4)/СУММЕСЛИМН(OO;ГР;C4;СО;B4;НР;A4;УП;F4;МУ;D4;КЗ;E4;Февраль_2026!$H$5:$H$20;"<>")

=СУММЕСЛИМН(OW;ГР;C4;СО;B4;НР;A4;УП;F4;МУ;D4;КЗ;E4)/СУММЕСЛИМН(OO;ГР;C4;СО;B4;НР;A4;УП;F4;МУ;D4;КЗ;E4;OW;"<>0")

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    
    If Target.Value = "" Then
    Else
        Dim clStru As Range, rnStru As Range
        On Error Resume Next
        Set clStru = Sheets("Структура").UsedRange.Find(What:=Target.Value, LookAt:=xlPart)
        On Error GoTo 0
        If Not clStru Is Nothing Then
            Set rnStru = GetStruSourceRange(clStru)
            If Not rnStru Is Nothing Then
                Dim aStru As Variant
                aStru = GetStruSourceArray(rnStru)
                Dim rTarg As Range
                Set rTarg = GetTargetRange(Target, aStru)
                Set rTarg = rTarg.Resize(UBound(aStru, 1), UBound(aStru, 2))
                PrintArray aStru, rTarg
            End If
        End If
        
        FillValidation Target.Parent, Sheets("Структура")
    End If
End Sub

Private Sub PrintArray(arr As Variant, rTarg As Range)
'    Application.EnableEvents = False
    'rTarg.Clear
    rTarg.Resize(rTarg.Parent.UsedRange.Rows.Count, rTarg.Parent.UsedRange.Columns.Count).Clear
    rTarg.Value = arr
'    Application.EnableEvents = True
    rTarg.EntireColumn.ColumnWidth = 3
    rTarg.EntireColumn.AutoFit
    
    Dim cl As Range
    For Each cl In rTarg.Rows(1).Cells
        If Not IsEmpty(cl.Value) Then
            With Intersect(cl.CurrentRegion, cl.EntireRow)
                With .Borders
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlMedium
                End With
                .Borders(xlInsideVertical).LineStyle = xlNone
                .Borders(xlInsideHorizontal).LineStyle = xlNone
            End With
        End If
    Next
End Sub

Private Function GetTargetRange(Target As Range, aStru As Variant) As Range
    Dim xl As Long
    xl = Int(UBound(aStru, 2) / 2)
    xl = Target.Column - xl
    If xl < 1 Then xl = 1
    
    Dim sh As Worksheet
    Set sh = Target.Parent
    
    Dim xx As Long, yy As Long, colEmpty As Boolean
    For xx = xl To Target.Column - 1
        colEmpty = True
        For yy = sh.UsedRange.Row To sh.UsedRange.Row + sh.UsedRange.Rows.Count - 1
            If Not IsEmpty(sh.Cells(yy, xx).Value) Then
                colEmpty = False
                Exit For
            End If
        Next
        If colEmpty Then
            Exit For
        End If
    Next
    If xl > 1 Then xl = xl + 1
    Set GetTargetRange = sh.Cells(Target.Row + 1, xl)
End Function

Private Function GetStruSourceArray(rnStru As Range) As Variant
    Dim res As Variant
    If rnStru.Cells.CountLarge = 1 Then
        ReDim res(1 To 1, 1 To 1)
        res(1, 1) = rnStru.Value
        GetStruSourceArray = res
        Exit Function
    End If
    
    res = rnStru.Value
    res = myTranspose(res)
    GetStruSourceArray = res
End Function

Private Function myTranspose(src As Variant) As Variant
    Dim trg As Variant
    ReDim trg(1 To UBound(src, 2), 1 To UBound(src, 1))
    
    Dim ys As Long, xs As Long
    For ys = 1 To UBound(src, 1)
    For xs = 1 To UBound(src, 2)
        trg(xs, ys) = src(ys, xs)
    Next
    Next
    myTranspose = trg
End Function

Private Function GetStruSourceRange(clStru As Range) As Range
    Dim sh As Worksheet
    Set sh = clStru.Parent
    
    If clStru.Column >= sh.UsedRange.Column + sh.UsedRange.Columns.Count - 1 Then Exit Function
    
    Dim yb As Long
    For yb = clStru.Row - 1 To sh.UsedRange.Row Step -1
        If Not IsEmpty(clStru.EntireColumn.Cells(yb, 1).Value) Then
            With clStru.EntireColumn.Cells(yb, 1).CurrentRegion
                yb = .Row + .Rows.Count - 1
            End With
            Exit For
        End If
    Next
    yb = yb + 1
    
    Dim yf As Long
    For yf = clStru.Row + 1 To sh.UsedRange.Row + sh.UsedRange.Rows.Count - 1
        If Not IsEmpty(clStru.EntireColumn.Cells(yf, 1).Value) Then
            With clStru.EntireColumn.Cells(yf, 1).CurrentRegion
                yf = .Row
            End With
            Exit For
        End If
    Next
    yf = yf - 1
    
    Dim res As Range
    Set res = clStru.Columns(2).EntireColumn.Resize(, sh.UsedRange.Columns.Count - clStru.Column)
    Set res = Intersect(res, sh.Rows(yb & ":" & yf))
    Set GetStruSourceRange = res
End Function

Private Sub FillValidation(shTarg As Worksheet, shSour As Worksheet)
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
'    Dim cl As Range
'    For Each cl In shSour.Cells.SpecialCells(xlCellTypeConstants, 2).Cells
'        If Not IsEmpty(cl.Value) Then
'            dic(cl.Value) = Empty
'        End If
'    Next
    Dim aur As Variant, ya As Long, xa As Long
    aur = shSour.UsedRange.Value
    For xa = 1 To UBound(aur, 2)
        For ya = 1 To UBound(aur, 1)
            If Not IsEmpty(aur(ya, xa)) Then
                dic(aur(ya, xa)) = Empty
            End If
        Next
    Next
    
    With shTarg.Cells(1, 1).Resize(2 * (shTarg.UsedRange.Row + shTarg.UsedRange.Rows.Count - 1), 2 * (shTarg.UsedRange.Column + shTarg.UsedRange.Columns.Count - 1)).Validation
        .Delete
        If dic.Count > 0 Then
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(dic.Keys(), ",")
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = False
        End If
    End With
End Sub

Option Explicit

Sub test()
    CloseEmptyWb
    TransformRange Columns("A:A"), Columns("D:D"), Columns("AU:AU"), Columns("AV:AV"), Columns("AW:AW")
End Sub

Private Sub TransformRange(ra As Range, rd As Range, ru As Range, rv As Range, rw As Range)
    Set rd = Intersect(rd, rd.Parent.UsedRange)
    Set rd = rd.Resize(rd.Rows.Count - 1)
    Set rd = rd.Offset(1)
    
    Set ra = Intersect(ra, rd.EntireRow)
    Set ru = Intersect(ru, rd.EntireRow)
    Set rv = Intersect(rv, rd.EntireRow)
    Set rw = Intersect(rw, rd.EntireRow)
    
    Dim ara As Variant, ard As Variant, aru As Variant, arv As Variant, arw As Variant
    ara = ra.Value
    ard = rd.Value
    aru = ru.Value
    arv = rv.Value
    arw = rw.Value
    
    Dim aHead As Variant
    ReDim aHead(1 To 1, 1 To 2)
    aHead(1, 1) = ru.Cells(0, 1).Value
    aHead(1, 2) = rw.Cells(0, 1).Value
    
    TransformArray ara, ard, aru, arv, arw, aHead
End Sub

Private Sub TransformArray(ara As Variant, ard As Variant, aru As Variant, arv As Variant, arw As Variant, aHead As Variant)
    Dim dic As Object, dix As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Set dix = CreateObject("Scripting.Dictionary")
    
    Dim ya As Long
    For ya = 1 To UBound(ara, 1)
        If ara(ya, 1) <> "" Then
            If Not dic.Exists(ara(ya, 1)) Then Set dic(ara(ya, 1)) = CreateObject("Scripting.Dictionary")
            If Not dic(ara(ya, 1)).Exists(aru(ya, 1)) Then Set dic(ara(ya, 1))(aru(ya, 1)) = CreateObject("Scripting.Dictionary")
            If Not dic(ara(ya, 1))(aru(ya, 1)).Exists(arw(ya, 1)) Then Set dic(ara(ya, 1))(aru(ya, 1))(arw(ya, 1)) = CreateObject("Scripting.Dictionary")
            If Not dic(ara(ya, 1))(aru(ya, 1))(arw(ya, 1)).Exists(arv(ya, 1)) Then Set dic(ara(ya, 1))(aru(ya, 1))(arw(ya, 1))(arv(ya, 1)) = CreateObject("Scripting.Dictionary")
            dic(ara(ya, 1))(aru(ya, 1))(arw(ya, 1))(arv(ya, 1))(ard(ya, 1)) = Empty
            
            dix(arv(ya, 1)) = Empty
        End If
    Next
    
    PrintDic dic, dix, aHead
End Sub

Private Sub PrintDic(dic As Object, dix As Object, aHead As Variant)
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    
    Dim rOut As Range
    Set rOut = Workbooks.Add(1).Sheets(1).Cells(1, 1)
    
    SortDic dic, rOut.Parent
    SortDic dix, rOut.Parent
    
    Dim vv As Variant
    For Each vv In dic
        Set rOut = rOut.EntireRow.Cells(2, 5)
        rOut.Value = vv
        With rOut.EntireRow.Cells(1, 3).Resize(1, dix.Count + 2)
            With .Borders: .LineStyle = xlContinuous: .ColorIndex = xlAutomatic: .TintAndShade = 0: .Weight = xlMedium: End With
            .Borders(xlInsideVertical).LineStyle = xlNone
        End With
        rOut.EntireRow.Cells(1, 3).Resize(2, dix.Count + 2).Interior.Color = RGB(217, 225, 242)
        
        Set rOut = rOut.Cells(2, 1)
        Set rOut = rOut.EntireRow.Cells(1, 3)
        With rOut.Resize(1, 2 + dix.Count).Borders: .LineStyle = xlContinuous: .ColorIndex = xlAutomatic: .TintAndShade = 0: .Weight = xlMedium: End With
                    
        rOut.Resize(UBound(aHead, 1), UBound(aHead, 2)).Value = aHead
        Set rOut = rOut.Cells(1, 3).Resize(, dix.Count)
        rOut.Value = dix.keys()
        Set rOut = rOut.EntireRow.Cells(2, 3)
        PrintMarg dic(vv), rOut, dix
    Next
    
    rOut.Parent.UsedRange.EntireColumn.AutoFit
    Application.Calculation = Application_Calculation
    rOut.Parent.Parent.Saved = True
End Sub

Private Sub PrintMarg(dic As Object, rOut As Range, dix As Object)
    Dim vv As Variant, bb As Variant, cc As Variant, dd As Variant, bic As Object, cic As Object, ddc As Object, xx As Long, col As Long
    For Each vv In dic.keys
        col = RGB(WorksheetFunction.RandBetween(255, 255), WorksheetFunction.RandBetween(150, 255), WorksheetFunction.RandBetween(150, 255))
        Set bic = dic(vv)
        For Each bb In bic.keys
            Set cic = bic(bb)
            For Each cc In cic.keys
                Set ddc = cic(cc)
                For Each dd In ddc.keys
                    rOut.Cells(1, 1).Value = vv
                    rOut.Cells(1, 2).Value = bb
                    xx = WorksheetFunction.Match(cc, dix.keys(), 0)
                    'rOut.Cells(1, xx + 2).Value = cic(cc)
                    rOut.Cells(1, xx + 2).Value = dd
                    With rOut.Resize(1, 2 + dix.Count)
                        .Interior.Color = col
                        With .Borders(xlEdgeLeft): .LineStyle = xlContinuous: .ColorIndex = xlAutomatic: .TintAndShade = 0: .Weight = xlMedium: End With
                        With .Borders(xlEdgeRight): .LineStyle = xlContinuous: .ColorIndex = xlAutomatic: .TintAndShade = 0: .Weight = xlMedium: End With
                    End With
                    
                    Set rOut = rOut.Cells(2, 1)
                Next
            Next
        Next
        With rOut.Resize(, 2 + dix.Count).Borders(xlEdgeTop): .LineStyle = xlContinuous: .ColorIndex = xlAutomatic: .TintAndShade = 0: .Weight = xlMedium: End With
    Next
End Sub

Private Sub SortDic(dic As Object, sh As Worksheet)
    Dim rr As Range
    Set rr = sh.Cells(1, 1).Resize(dic.Count)
    rr.Value = Application.Transpose(dic.keys())
    
    With sh.Sort
        .SortFields.Clear
        .SortFields.Add Key:=rr, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange rr
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Dim arr As Variant
    If rr.Cells.Count = 1 Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = rr.Value
    Else
        arr = rr.Value
    End If
    sh.UsedRange.Clear
    
    Dim bic As Object, cic As Object
    Set bic = CreateObject("Scripting.Dictionary")
    
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        If TypeName(dic(arr(ya, 1))) = "Dictionary" Then
            Set cic = dic(arr(ya, 1))
            SortDic cic, sh
            Set bic(arr(ya, 1)) = cic
        Else
            bic(arr(ya, 1)) = dic(arr(ya, 1))
        End If
    Next
    Set dic = bic
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

Option Explicit
'v2
Sub Оставить_закрашенные()
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
        
    CloseEmptyWb
    ActiveSheet.Copy
    KeepColored ActiveSheet, RGB(255, 255, 255), fixedValueColumns:=1
    
    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
    ActiveWorkbook.Saved = True
End Sub

Private Sub KeepColored(sh As Worksheet, col As Long, fixedValueColumns As String)
    FixValues sh, fixedValueColumns
    
    Dim yu As Long, xu As Long
    For yu = sh.UsedRange.Rows.Count To 1 Step -1
        For xu = 1 To sh.UsedRange.Columns.Count
            If sh.UsedRange.Cells(yu, xu).Interior.Color <> col Then
                GoTo keepRow
            End If
        Next
        sh.UsedRange.Rows(yu).EntireRow.Delete
        GoTo skipRow
keepRow:
        For xu = 1 To sh.UsedRange.Columns.Count
            If sh.UsedRange.Cells(yu, xu).Interior.Color = col Then
                sh.UsedRange.Cells(yu, xu).ClearContents
            End If
        Next
skipRow:
    Next
End Sub

Private Sub FixValues(sh, fixedValueColumns As String)
    If fixedValueColumns = "" Then Exit Sub
    
    Dim vv As Variant
    For Each vv In Split(fixedValueColumns)
        sh.UsedRange.Columns(CLng(vv)).Value = sh.UsedRange.Columns(CLng(vv)).Value
    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

Option Explicit

Sub Оставить_закрашенные()
    CloseEmptyWb
    ActiveSheet.Copy
    KeepColored ActiveSheet
End Sub

Private Sub KeepColored(sh As Worksheet)
    sh.UsedRange.Columns(1).Value = sh.UsedRange.Columns(1).Value
    
    Dim yu As Long, xu As Long
    For yu = sh.UsedRange.Rows.Count To 1 Step -1
        For xu = 1 To sh.UsedRange.Columns.Count
            If sh.UsedRange.Cells(yu, xu).Interior.Color <> RGB(255, 255, 255) Then
                GoTo keepRow
            End If
        Next
        sh.UsedRange.Rows(yu).EntireRow.Delete
keepRow:
    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

Sub Обновить_отчёт()
    Dim dic As Object
    Set dic = GetDic(Sheets("Данные ").ListObjects("Smart_BD_status"))
    PrintDic dic
End Sub

Private Sub PrintDic(dic As Object)
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    Dim sh As Worksheet
    Set sh = Sheets("Отчет ")
    
    sh.Rows(5).Resize(sh.UsedRange.Rows.Count).Delete
    
    Dim rPrint As Range
    Set rPrint = sh.Cells(1, 1)
    
    Dim ys As Variant, yi As Long, idc As Object
    For ys = 0 To dic.Count - 1
        If ys > 0 Then
            sh.Rows("1:4").Copy rPrint
        End If
        rPrint.Cells(1, 2).Value = dic.Keys()(ys)
        
        Set rPrint = rPrint.Cells(4, 1)
        rPrint.Cells(1, 2).Value = dic.Keys()(ys)
        Set idc = dic.Items()(ys)
        If idc.Count > 1 Then
            rPrint.EntireRow.Copy
            rPrint.Rows(2).EntireRow.Resize(idc.Count - 1).Insert
            Application.CutCopyMode = False
        End If
        For yi = 0 To idc.Count - 1
            rPrint.Cells(1 + yi, 1).Value = idc.Keys()(yi)
        Next
        
        Set rPrint = rPrint.Cells(5 + idc.Count, 1)
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Private Function GetDic(tb As ListObject) As Object
    Dim arr As Variant
    ReDim arr(1 To 2)
    arr(1) = tb.ListColumns("ID").DataBodyRange.Value
    arr(2) = tb.ListColumns("Статус ").DataBodyRange.Value
    
    Dim dicID As Object
    Set dicID = CreateObject("Scripting.Dictionary")
    
    Dim yt As Long
    For yt = 1 To UBound(arr(1), 1)
        If Not IsEmpty(arr(1)(yt, 1)) Then
            dicID(arr(1)(yt, 1)) = arr(2)(yt, 1)
        End If
    Next

    Dim dicSt As Object, ii As Variant
    Set dicSt = CreateObject("Scripting.Dictionary")
    For Each ii In dicID.Keys
        If Not dicSt.Exists(dicID(ii)) Then Set dicSt(dicID(ii)) = CreateObject("Scripting.Dictionary")
        dicSt(dicID(ii))(ii) = Empty
    Next
    
    Set GetDic = dicSt
End Function

Option Explicit

Sub test()
    CloseEmptyWb
    TransformRange Columns("A:A"), Columns("D:D"), Columns("AU:AU"), Columns("AV:AV"), Columns("AW:AW")
End Sub

Private Sub TransformRange(ra As Range, rd As Range, ru As Range, rv As Range, rw As Range)
    Set rd = Intersect(rd, rd.Parent.UsedRange)
    Set rd = rd.Resize(rd.Rows.Count - 1)
    Set rd = rd.Offset(1)
    
    Set ra = Intersect(ra, rd.EntireRow)
    Set ru = Intersect(ru, rd.EntireRow)
    Set rv = Intersect(rv, rd.EntireRow)
    Set rw = Intersect(rw, rd.EntireRow)
    
    Dim ara As Variant, ard As Variant, aru As Variant, arv As Variant, arw As Variant
    ara = ra.Value
    ard = rd.Value
    aru = ru.Value
    arv = rv.Value
    arw = rw.Value
    
    Dim aHead As Variant
    ReDim aHead(1 To 1, 1 To 2)
    aHead(1, 1) = ru.Cells(0, 1).Value
    aHead(1, 2) = rw.Cells(0, 1).Value
    
    TransformArray ara, ard, aru, arv, arw, aHead
End Sub

Private Sub TransformArray(ara As Variant, ard As Variant, aru As Variant, arv As Variant, arw As Variant, aHead As Variant)
    Dim dic As Object, dix As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Set dix = CreateObject("Scripting.Dictionary")
    
    Dim ya As Long
    For ya = 1 To UBound(ara, 1)
        If ara(ya, 1) <> "" Then
            If Not dic.Exists(ara(ya, 1)) Then Set dic(ara(ya, 1)) = CreateObject("Scripting.Dictionary")
            If Not dic(ara(ya, 1)).Exists(aru(ya, 1)) Then Set dic(ara(ya, 1))(aru(ya, 1)) = CreateObject("Scripting.Dictionary")
            If Not dic(ara(ya, 1))(aru(ya, 1)).Exists(arw(ya, 1)) Then Set dic(ara(ya, 1))(aru(ya, 1))(arw(ya, 1)) = CreateObject("Scripting.Dictionary")
            If Not dic(ara(ya, 1))(aru(ya, 1))(arw(ya, 1)).Exists(arv(ya, 1)) Then dic(ara(ya, 1))(aru(ya, 1))(arw(ya, 1))(arv(ya, 1)) = ard(ya, 1)
            
            
            dix(arv(ya, 1)) = Empty
        End If
    Next
    
    PrintDic dic, dix, aHead
End Sub

Private Sub PrintDic(dic As Object, dix As Object, aHead As Variant)
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    
    Dim rOut As Range
    Set rOut = Workbooks.Add(1).Sheets(1).Cells(1, 1)
    
    SortDic dic, rOut.Parent
    SortDic dix, rOut.Parent
    
    Dim vv As Variant
    For Each vv In dic
        Set rOut = rOut.EntireRow.Cells(2, 5)
        rOut.Value = vv
        With rOut.EntireRow.Cells(1, 3).Resize(1, dix.Count + 2)
            With .Borders: .LineStyle = xlContinuous: .ColorIndex = xlAutomatic: .TintAndShade = 0: .Weight = xlMedium: End With
            .Borders(xlInsideVertical).LineStyle = xlNone
        End With
        rOut.EntireRow.Cells(1, 3).Resize(2, dix.Count + 2).Interior.Color = RGB(217, 225, 242)
        
        Set rOut = rOut.Cells(2, 1)
        Set rOut = rOut.EntireRow.Cells(1, 3)
        With rOut.Resize(1, 2 + dix.Count).Borders: .LineStyle = xlContinuous: .ColorIndex = xlAutomatic: .TintAndShade = 0: .Weight = xlMedium: End With
                    
        rOut.Resize(UBound(aHead, 1), UBound(aHead, 2)).Value = aHead
        Set rOut = rOut.Cells(1, 3).Resize(, dix.Count)
        rOut.Value = dix.keys()
        Set rOut = rOut.EntireRow.Cells(2, 3)
        PrintMarg dic(vv), rOut, dix
    Next
    
    rOut.Parent.UsedRange.EntireColumn.AutoFit
    Application.Calculation = Application_Calculation
    rOut.Parent.Parent.Saved = True
End Sub

Private Sub PrintMarg(dic As Object, rOut As Range, dix As Object)
    Dim vv As Variant, bb As Variant, cc As Variant, bic As Object, cic As Object, xx As Long, col As Long
    For Each vv In dic.keys
        col = RGB(WorksheetFunction.RandBetween(255, 255), WorksheetFunction.RandBetween(150, 255), WorksheetFunction.RandBetween(150, 255))
        Set bic = dic(vv)
        For Each bb In bic.keys
            Set cic = bic(bb)
            For Each cc In cic.keys
                rOut.Cells(1, 1).Value = vv
                rOut.Cells(1, 2).Value = bb
                xx = WorksheetFunction.Match(cc, dix.keys(), 0)
                rOut.Cells(1, xx + 2).Value = cic(cc)
                With rOut.Resize(1, 2 + dix.Count)
                    .Interior.Color = col
                    With .Borders(xlEdgeLeft): .LineStyle = xlContinuous: .ColorIndex = xlAutomatic: .TintAndShade = 0: .Weight = xlMedium: End With
                    With .Borders(xlEdgeRight): .LineStyle = xlContinuous: .ColorIndex = xlAutomatic: .TintAndShade = 0: .Weight = xlMedium: End With
                End With
                
                Set rOut = rOut.Cells(2, 1)
            Next
        Next
        With rOut.Resize(, 2 + dix.Count).Borders(xlEdgeTop): .LineStyle = xlContinuous: .ColorIndex = xlAutomatic: .TintAndShade = 0: .Weight = xlMedium: End With
    Next
End Sub

Private Sub SortDic(dic As Object, sh As Worksheet)
    Dim rr As Range
    Set rr = sh.Cells(1, 1).Resize(dic.Count)
    rr.Value = Application.Transpose(dic.keys())
    
    With sh.Sort
        .SortFields.Clear
        .SortFields.Add Key:=rr, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange rr
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Dim arr As Variant
    If rr.Cells.Count = 1 Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = rr.Value
    Else
        arr = rr.Value
    End If
    sh.UsedRange.Clear
    
    Dim bic As Object, cic As Object
    Set bic = CreateObject("Scripting.Dictionary")
    
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        If TypeName(dic(arr(ya, 1))) = "Dictionary" Then
            Set cic = dic(arr(ya, 1))
            SortDic cic, sh
            Set bic(arr(ya, 1)) = cic
        Else
            bic(arr(ya, 1)) = dic(arr(ya, 1))
        End If
    Next
    Set dic = bic
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

Option Explicit

Sub test()
    CloseEmptyWb
    TransformRange Columns("A:A"), Columns("D:D"), Columns("AU:AU"), Columns("AV:AV"), Columns("AW:AW")
End Sub

Private Sub TransformRange(ra As Range, rd As Range, ru As Range, rv As Range, rw As Range)
    Set rd = Intersect(rd, rd.Parent.UsedRange)
    Set rd = rd.Resize(rd.Rows.Count - 1)
    Set rd = rd.Offset(1)
    
    Set ra = Intersect(ra, rd.EntireRow)
    Set ru = Intersect(ru, rd.EntireRow)
    Set rv = Intersect(rv, rd.EntireRow)
    Set rw = Intersect(rw, rd.EntireRow)
    
    Dim ara As Variant, ard As Variant, aru As Variant, arv As Variant, arw As Variant
    ara = ra.Value
    ard = rd.Value
    aru = ru.Value
    arv = rv.Value
    arw = rw.Value
    TransformArray ara, ard, aru, arv, arw
End Sub

Private Sub TransformArray(ara As Variant, ard As Variant, aru As Variant, arv As Variant, arw As Variant)
    Dim dic As Object, dix As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Set dix = CreateObject("Scripting.Dictionary")
    
    Dim ya As Long
    For ya = 1 To UBound(ara, 1)
        If ara(ya, 1) <> "" Then
            If Not dic.Exists(ara(ya, 1)) Then Set dic(ara(ya, 1)) = CreateObject("Scripting.Dictionary")
            If Not dic(ara(ya, 1)).Exists(aru(ya, 1)) Then Set dic(ara(ya, 1))(aru(ya, 1)) = CreateObject("Scripting.Dictionary")
            If Not dic(ara(ya, 1))(aru(ya, 1)).Exists(arw(ya, 1)) Then Set dic(ara(ya, 1))(aru(ya, 1))(arw(ya, 1)) = CreateObject("Scripting.Dictionary")
            If Not dic(ara(ya, 1))(aru(ya, 1))(arw(ya, 1)).Exists(arv(ya, 1)) Then dic(ara(ya, 1))(aru(ya, 1))(arw(ya, 1))(arv(ya, 1)) = ard(ya, 1)
            
            
            dix(arv(ya, 1)) = Empty
        End If
    Next
    
    PrintDic dic, dix
End Sub

Private Sub PrintDic(dic As Object, dix As Object)
    Dim rOut As Range
    Set rOut = Workbooks.Add(1).Sheets(1).Cells(2, 5)
    
    Dim vv As Variant
    For Each vv In dic
        rOut.Value = vv
        Set rOut = rOut.Cells(2, 1).Resize(, dix.Count)
        rOut.Value = dix.Keys()
        Set rOut = rOut.Cells(2, 1)
        Set rOut = rOut.Offset(0, -2)
        PrintMarg dic(vv), rOut, dix
    Next
End Sub

Private Sub PrintMarg(dic As Object, rOut As Range, dix As Object)
    Dim vv As Variant, bb As Variant, cc As Variant, bic As Object, cic As Object, xx As Long
    For Each vv In dic.Keys
        Set bic = dic(vv)
        For Each bb In bic.Keys
            Set cic = bic(bb)
            For Each cc In cic.Keys
                rOut.Cells(1, 1).Value = vv
                rOut.Cells(1, 2).Value = bb
                
                xx = WorksheetFunction.Match(cc, dix.Keys(), 0)
                
                rOut.Cells(1, xx + 2).Value = cic(cc)
                Set rOut = rOut.Cells(2, 1)
            Next
        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

=СЖПРОБЕЛЫ(ПСТР(ПОДСТАВИТЬ(ПОДСТАВИТЬ($B4;".";":");"-";ПОВТОР(" ";100));100*(СТОЛБЕЦ(A:A)-1)+1;100))

=ИНДЕКС('Шахматка (4 кв.2025)'!C$4:C$39;ПОИСКПОЗ($D2;СМЕЩ('Шахматка (4 кв.2025)'!$D$4:$D$39;0;(СЧЁТЕСЛИМН('Шахматка (4 кв.2025)'!$E:$E;$D:$D)>0)+2*(СЧЁТЕСЛИМН('Шахматка (4 кв.2025)'!$F:$F;$D:$D)>0)+3*(СЧЁТЕСЛИМН('Шахматка (4 кв.2025)'!$G:$G;$D:$D)>0));0))

=ИНДЕКС('Шахматка (4 кв.2025)'!$E$3:$G$3;(СЧЁТЕСЛИМН('Шахматка (4 кв.2025)'!$E:$E;$D:$D)>0)+2*(СЧЁТЕСЛИМН('Шахматка (4 кв.2025)'!$F:$F;$D:$D)>0)+3*(СЧЁТЕСЛИМН('Шахматка (4 кв.2025)'!$G:$G;$D:$D)>0))

=ИНДЕКС('Шахматка (4 кв.2025)'!D$4:D$39;ПОИСКПОЗ($D2;СМЕЩ('Шахматка (4 кв.2025)'!$D$4:$D$39;0;(СЧЁТЕСЛИМН('Шахматка (4 кв.2025)'!$E:$E;$D:$D)>0)+2*(СЧЁТЕСЛИМН('Шахматка (4 кв.2025)'!$F:$F;$D:$D)>0)+3*(СЧЁТЕСЛИМН('Шахматка (4 кв.2025)'!$G:$G;$D:$D)>0));0))

=C2&ЕСЛИ(A2=A3;"; "&F3;"")

Option Explicit
Private aSour As Variant
Private aIndx As Variant
Private aComb As Variant
Private dic As Dictionary

Private Sub CommandButton2_Click()
    Unload Me
End Sub

Private Sub TextBox1_Change()
    ChangeAddress
End Sub

Private Sub TextBox2_Change()
    ChangeAddress
End Sub

Private Sub TextBox4_Change()
    ChangeAddress
End Sub

Private Sub ChangeAddress()
    Dim rSour As Range
    On Error Resume Next
    Set rSour = Лист1.Range(Me.TextBox4.Value).Resize(TextBox2.Value, TextBox1.Value)
    If Err = 0 Then
        LabelAddress.Caption = rSour.Address(0, 0, xlA1)
        aSour = rSour.Value
        aSour = TransformSourceArray(aSour)
    End If
    On Error GoTo 0
End Sub

Private Function TransformSourceArray(aSour As Variant) As Variant
    Dim arr As Variant, brr As Variant
    ReDim arr(LBound(aSour, 1) To UBound(aSour, 1))
    ReDim brr(LBound(aSour, 2) To UBound(aSour, 2)) As Boolean
    
    Dim ya As Long, xa As Long
    For ya = LBound(arr) To UBound(arr)
        For xa = LBound(brr) To UBound(brr)
            brr(xa) = aSour(ya, xa) = 1
        Next
        arr(ya) = brr
    Next
    
    TransformSourceArray = arr
End Function

Private Sub TextBox5_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
    If Not IsDate(TextBox5.Value) Then
        TextBox5.Value = "0:01:00"
        Cancel = True
    End If
End Sub

Private Sub TextBox5_Change()
    ThisWorkbook.Names("остановка_через").RefersToRange.Value = TextBox5.Text
End Sub

Private Sub UserForm_Initialize()
    Randomize
    TextBox5.Text = ThisWorkbook.Names("остановка_через").RefersToRange.Text
    ChangeAddress
End Sub

Private Sub CommandButton1_Click()
    Static dtExit As Date
    On Error Resume Next
    Application.OnTime EarliestTime:=dtExit, Procedure:="SetExitFlag", Schedule:=False
    On Error GoTo 0
    dtExit = Now + CDate(TextBox5.Text)
    exitFlag = False
    Application.OnTime dtExit, "SetExitFlag"
    
    Application.StatusBar = "Следующая остановка после " & Format(dtExit, "hh:mm:ss")
    Me.Hide
    Me.TextBox1.Enabled = False
    Me.TextBox2.Enabled = False
    Me.TextBox3.Enabled = False
    Me.TextBox4.Enabled = False
    
    If dic Is Nothing Then
        Set dic = New Dictionary
        ReDim aComb(1 To UBound(aSour(1)))
'        Лист2.Cells.ClearContents
        Лист2.Select
    End If
    FindBestСombination
    Application.StatusBar = False
End Sub

Private Sub FindBestСombination()
    Do
        VaryComb

        If exitFlag Then
            Exit Do
        End If
        DoEvents
    Loop
    PrintResult aComb
    Me.Show
End Sub
Private Sub VaryComb()
    
    Dim cmpRow As Variant
    Dim optRow As Variant
    Dim optRows As Variant
    Dim cIndx As Variant
    'Dim sDone As String
    Dim aDone As Variant
    ReDim aDone(1 To UBound(aSour)) As Boolean
    
    Dim yf As Long, yo As Long, ySour As Long, nComb As Long
    For yf = 1 To UBound(aSour(1))
        optRows = GetOptRows(cmpRow)
        AddRndRow optRows
        yo = Rnd() * UBound(optRows)
        ySour = optRows(yo)
'        ySour = Int(Rnd() * UBound(aSour)) + 1
        optRow = aSour(ySour)
        cmpRow = SumRows(optRow, cmpRow)
        aDone(ySour) = True
        cIndx = GetIndxArray(aDone)
        nComb = UBound(cIndx)
        GetUniqCountAndAddDic cIndx, nComb
        'Debug.Print yf, ySour, UniqCount(cmpRow), nComb ', sDone
        DoEvents
    Next
End Sub

Private Sub AddRndRow(optRows As Variant)
    ReDim Preserve optRows(LBound(optRows) To UBound(optRows) + 1)
    optRows(UBound(optRows)) = Int(Rnd() * UBound(aSour)) + 1
End Sub

Private Function GetIndxArray(aDone As Variant) As Variant
    Dim va As Variant, ya As Long
    For Each va In aDone
        If va Then ya = ya + 1
    Next
    If ya > 0 Then
        Dim arr As Variant, yDone As Long
        ReDim arr(1 To ya)
        ya = LBound(arr)
        yDone = LBound(aDone)
        For Each va In aDone
            If va Then
                arr(ya) = yDone
                ya = ya + 1
            End If
            yDone = yDone + 1
        Next
        GetIndxArray = arr
    End If
End Function

Private Function GetOptRows(cmpRow As Variant) As Variant
    Dim ya As Long, curCount As Long, optCount As Long, optRows As String, sumRow As Variant
    For ya = 1 To UBound(aSour)
        sumRow = SumRows(aSour(ya), cmpRow)
        curCount = UniqCount(sumRow)
        If optCount < curCount Then
            optCount = curCount
            optRows = ya
        ElseIf curCount = optCount Then
            optRows = optRows & " " & ya
        End If
    Next
    GetOptRows = Split(optRows, " ")
End Function
'    Do
'        aIndx_Init
'        GetUniqCountAndAddDic aIndx
'
'
'        If exitFlag Then
'            Exit Do
'        End If
'        DoEvents
'    Loop
'    PrintResult aComb
'    Me.Show


Private Function SumRows(arr As Variant, brr As Variant) As Variant
    If IsEmpty(brr) Then
        SumRows = arr
        Exit Function
    ElseIf IsEmpty(arr) Then
        SumRows = brr
        Exit Function
    End If
    
    Dim crr As Variant, ya As Long
    ReDim crr(LBound(arr) To UBound(arr)) As Boolean
    For ya = LBound(arr) To UBound(arr)
        crr(ya) = arr(ya) Or brr(ya)
    Next
    SumRows = crr
End Function

Private Function UniqCount(arr As Variant) As Long
    Dim va As Variant
    For Each va In arr
        If va Then UniqCount = UniqCount + 1
    Next
End Function

Private Function GetUniqCountAndAddDic(cIndx As Variant, nComb As Long) As Long
    Dim sIndx As String
    sIndx = Join(cIndx, " ")
    
    If dic.Exists(sIndx) Then
        GetUniqCountAndAddDic = dic(sIndx)
        Exit Function
    End If
    
    Dim curUniqCount As Long
    curUniqCount = CountUniq(cIndx, aSour)
    
    Dim combItem As Variant
    
    If IsEmpty(aComb(nComb)) Then
        ReDim combItem(1 To UBound(aSour(1)))
        aComb(nComb) = combItem
        combItem = Empty
    End If
    
    If IsEmpty(aComb(nComb)(curUniqCount)) Then
        ReDim combItem(1 To 1)
    Else
        combItem = aComb(nComb)(curUniqCount)
        ReDim Preserve combItem(1 To UBound(combItem) + 1)
    End If
    combItem(UBound(combItem)) = cIndx
    aComb(nComb)(curUniqCount) = combItem
    dic(sIndx) = curUniqCount
    GetUniqCountAndAddDic = curUniqCount
End Function

Private Sub aIndx_Init()
    If IsEmpty(aIndx) Then
        ReDim aIndx(1 To 1)
    End If
    
    Dim xa As Long
    For xa = LBound(aIndx) To UBound(aIndx)
        aIndx(xa) = xa
    Next
End Sub

Private Function CountUniq(aIndx As Variant, aSour As Variant) As Long
    Dim iInd As Long, iCount As Long, xs As Long, ys As Long
    Dim aDone As Variant
    ReDim aDone(1 To UBound(aSour(1))) As Boolean
    
    For iInd = LBound(aIndx) To UBound(aIndx)
        ys = aIndx(iInd)
        If ys <= UBound(aSour) Then
            For xs = 1 To UBound(aSour(ys))
                If aSour(ys)(xs) Then
                    If Not aDone(xs) Then
                        aDone(xs) = True
                        iCount = iCount + 1
                    End If
                End If
            Next
        End If
    Next
    CountUniq = iCount
End Function

Private Sub PrintResult(aComb As Variant)
    Dim rTarget As Range
    Set rTarget = Лист2.Cells(1, 1)
    rTarget.Parent.UsedRange.ClearContents
    
    Dim yc As Long, xt As Long
    xt = 1
    For yc = UBound(aComb) To LBound(aComb) Step -1
        If Not IsEmpty(aComb(yc)) Then
            Set rTarget = Лист2.Cells(2, xt)
            rTarget.Cells(0, 1).Resize(1, 2).Value = Array("Комбинаций", yc)
            PrintResultOneCombo aComb(yc), rTarget
            xt = xt + 3
        End If
    Next
    
    rTarget.Parent.Parent.Saved = True
End Sub

Private Sub PrintResultOneCombo(aComb, rTarget As Range)
    rTarget.Cells(1, 1).Resize(1, 3).Value = Array("Уникальных", "Коробки", Empty)
    Set rTarget = rTarget.Cells(2, 1)
    
    Dim yc As Long, yb As Long, arr As Variant, hrr As Variant, brr As Variant
    For yc = UBound(aComb) To LBound(aComb) Step -1
        If Not IsEmpty(aComb(yc)) Then
            arr = aComb(yc)
            ReDim brr(1 To UBound(arr), 1 To 2)
            If rTarget.Row + UBound(brr, 1) > rTarget.Parent.Rows.Count Then
                Set rTarget = rTarget.Cells(1, UBound(brr, 2) + 2).EntireColumn.Cells(1, 1)
                If rTarget.Row + UBound(brr, 1) > rTarget.Parent.Rows.Count Then
                    Exit For
                End If
            End If
            
            For yb = LBound(arr) To UBound(arr)
                brr(yb, 1) = yc
                brr(yb, 2) = Join(arr(yb), ", ")
            Next
            Set rTarget = rTarget.Cells(1, 1).Resize(UBound(brr, 1), UBound(brr, 2))
            rTarget.Value = brr
            Set rTarget = rTarget.Cells(rTarget.Rows.Count + 2, 1)
        End If
    Next
    
End Sub

Option Explicit
Private aSour As Variant
Private aIndx As Variant
Private aComb As Variant
Private dic As Dictionary

Private Sub CommandButton2_Click()
    Unload Me
End Sub

Private Sub TextBox1_Change()
    ChangeAddress
End Sub

Private Sub TextBox2_Change()
    ChangeAddress
End Sub

Private Sub TextBox4_Change()
    ChangeAddress
End Sub

Private Sub ChangeAddress()
    Dim rSour As Range
    On Error Resume Next
    Set rSour = Лист1.Range(Me.TextBox4.Value).Resize(TextBox2.Value, TextBox1.Value)
    If Err = 0 Then
        LabelAddress.Caption = rSour.Address(0, 0, xlA1)
        aSour = rSour.Value
        aSour = TransformSourceArray(aSour)
    End If
    On Error GoTo 0
End Sub

Private Function TransformSourceArray(aSour As Variant) As Variant
    Dim arr As Variant, brr As Variant
    ReDim arr(LBound(aSour, 1) To UBound(aSour, 1))
    ReDim brr(LBound(aSour, 2) To UBound(aSour, 2)) As Boolean
    
    Dim ya As Long, xa As Long
    For ya = LBound(arr) To UBound(arr)
        For xa = LBound(brr) To UBound(brr)
            brr(xa) = aSour(ya, xa) = 1
        Next
        arr(ya) = brr
    Next
    
    TransformSourceArray = arr
End Function

Private Sub TextBox5_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
    If Not IsDate(TextBox5.Value) Then
        TextBox5.Value = "0:01:00"
        Cancel = True
    End If
End Sub

Private Sub TextBox5_Change()
    ThisWorkbook.Names("остановка_через").RefersToRange.Value = TextBox5.Text
End Sub

Private Sub UserForm_Initialize()
    Randomize
    TextBox5.Text = ThisWorkbook.Names("остановка_через").RefersToRange.Text
    ChangeAddress
End Sub

Private Sub CommandButton1_Click()
    Static dtExit As Date
    On Error Resume Next
    Application.OnTime EarliestTime:=dtExit, Procedure:="SetExitFlag", Schedule:=False
    On Error GoTo 0
    dtExit = Now + CDate(TextBox5.Text)
    exitFlag = False
    Application.OnTime dtExit, "SetExitFlag"
    
    Application.StatusBar = "Следующая остановка после " & Format(dtExit, "hh:mm:ss")
    Me.Hide
    Me.TextBox1.Enabled = False
    Me.TextBox2.Enabled = False
    Me.TextBox3.Enabled = False
    Me.TextBox4.Enabled = False
    
    If dic Is Nothing Then
        Set dic = New Dictionary
        ReDim aComb(1 To UBound(aSour(1)))
'        Лист2.Cells.ClearContents
        Лист2.Select
    End If
    FindBestСombination
End Sub

Private Sub FindBestСombination()
    Do
        VaryComb

        If exitFlag Then
            Exit Do
        End If
        DoEvents
    Loop
    PrintResult aComb
    Me.Show
End Sub
Private Sub VaryComb()
    
    Dim cmpRow As Variant
    Dim optRow As Variant
    Dim optRows As Variant
    Dim cIndx As Variant
    'Dim sDone As String
    Dim aDone As Variant
    ReDim aDone(1 To UBound(aSour)) As Boolean
    
    Dim yf As Long, yo As Long, ySour As Long, nComb As Long
    For yf = 1 To UBound(aSour(1))
        optRows = GetOptRows(cmpRow)
        yo = Rnd() * UBound(optRows)
        ySour = optRows(yo)
        optRow = aSour(ySour)
        cmpRow = SumRows(optRow, cmpRow)
        'sDone = sDone & " " & ySour
        aDone(ySour) = True
        cIndx = GetIndxArray(aDone)
        nComb = UBound(cIndx)
        GetUniqCountAndAddDic cIndx, nComb
        'Debug.Print yf, ySour, UniqCount(cmpRow), nComb ', sDone
        DoEvents
    Next
End Sub

Private Function GetIndxArray(aDone As Variant) As Variant
    Dim va As Variant, ya As Long
    For Each va In aDone
        If va Then ya = ya + 1
    Next
    If ya > 0 Then
        Dim arr As Variant, yDone As Long
        ReDim arr(1 To ya)
        ya = LBound(arr)
        yDone = LBound(aDone)
        For Each va In aDone
            If va Then
                arr(ya) = yDone
                ya = ya + 1
            End If
            yDone = yDone + 1
        Next
        GetIndxArray = arr
    End If
End Function

Private Function GetOptRows(cmpRow As Variant) As Variant
    Dim ya As Long, curCount As Long, optCount As Long, optRows As String, sumRow As Variant
    For ya = 1 To UBound(aSour)
        sumRow = SumRows(aSour(ya), cmpRow)
        curCount = UniqCount(sumRow)
        If optCount < curCount Then
            optCount = curCount
            optRows = ya
        ElseIf curCount = optCount Then
            optRows = optRows & " " & ya
        End If
    Next
    GetOptRows = Split(optRows, " ")
End Function
'    Do
'        aIndx_Init
'        GetUniqCountAndAddDic aIndx
'
'
'        If exitFlag Then
'            Exit Do
'        End If
'        DoEvents
'    Loop
'    PrintResult aComb
'    Me.Show


Private Function SumRows(arr As Variant, brr As Variant) As Variant
    If IsEmpty(brr) Then
        SumRows = arr
        Exit Function
    ElseIf IsEmpty(arr) Then
        SumRows = brr
        Exit Function
    End If
    
    Dim crr As Variant, ya As Long
    ReDim crr(LBound(arr) To UBound(arr)) As Boolean
    For ya = LBound(arr) To UBound(arr)
        crr(ya) = arr(ya) Or brr(ya)
    Next
    SumRows = crr
End Function

Private Function UniqCount(arr As Variant) As Long
    Dim va As Variant
    For Each va In arr
        If va Then UniqCount = UniqCount + 1
    Next
End Function

Private Function GetUniqCountAndAddDic(cIndx As Variant, nComb As Long) As Long
    Dim sIndx As String
    sIndx = Join(cIndx, " ")
    
    If dic.Exists(sIndx) Then
        GetUniqCountAndAddDic = dic(sIndx)
        Exit Function
    End If
    
    Dim curUniqCount As Long
    curUniqCount = CountUniq(cIndx, aSour)
    
    Dim combItem As Variant
    
    If IsEmpty(aComb(nComb)) Then
        ReDim combItem(1 To UBound(aSour(1)))
        aComb(nComb) = combItem
        combItem = Empty
    End If
    
    If IsEmpty(aComb(nComb)(curUniqCount)) Then
        ReDim combItem(1 To 1)
    Else
        combItem = aComb(nComb)(curUniqCount)
        ReDim Preserve combItem(1 To UBound(combItem) + 1)
    End If
    combItem(UBound(combItem)) = cIndx
    aComb(nComb)(curUniqCount) = combItem
    dic(sIndx) = curUniqCount
    GetUniqCountAndAddDic = curUniqCount
End Function

Private Sub aIndx_Init()
    If IsEmpty(aIndx) Then
        ReDim aIndx(1 To 1)
    End If
    
    Dim xa As Long
    For xa = LBound(aIndx) To UBound(aIndx)
        aIndx(xa) = xa
    Next
End Sub

Private Function CountUniq(aIndx As Variant, aSour As Variant) As Long
    Dim iInd As Long, iCount As Long, xs As Long, ys As Long
    Dim aDone As Variant
    ReDim aDone(1 To UBound(aSour(1))) As Boolean
    
    For iInd = LBound(aIndx) To UBound(aIndx)
        ys = aIndx(iInd)
        If ys <= UBound(aSour) Then
            For xs = 1 To UBound(aSour(ys))
                If aSour(ys)(xs) Then
                    If Not aDone(xs) Then
                        aDone(xs) = True
                        iCount = iCount + 1
                    End If
                End If
            Next
        End If
    Next
    CountUniq = iCount
End Function

Private Sub PrintResult(aComb As Variant)
    Dim rTarget As Range
    Set rTarget = Лист2.Cells(1, 1)
    rTarget.Parent.UsedRange.ClearContents
    
    Dim yc As Long, xt As Long
    xt = 1
    For yc = UBound(aComb) To LBound(aComb) Step -1
        If Not IsEmpty(aComb(yc)) Then
            Set rTarget = Лист2.Cells(2, xt)
            rTarget.Cells(0, 1).Resize(1, 2).Value = Array("Комбинаций", yc)
            PrintResultOneCombo aComb(yc), rTarget
            xt = xt + 3
        End If
    Next
    
    rTarget.Parent.Parent.Saved = True
End Sub

Private Sub PrintResultOneCombo(aComb, rTarget As Range)
    rTarget.Cells(1, 1).Resize(1, 3).Value = Array("Уникальных", "Коробки", Empty)
    Set rTarget = rTarget.Cells(2, 1)
    
    Dim yc As Long, yb As Long, arr As Variant, hrr As Variant, brr As Variant
    For yc = UBound(aComb) To LBound(aComb) Step -1
        If Not IsEmpty(aComb(yc)) Then
            arr = aComb(yc)
            ReDim brr(1 To UBound(arr), 1 To 2)
            If rTarget.Row + UBound(brr, 1) > rTarget.Parent.Rows.Count Then
                Set rTarget = rTarget.Cells(1, UBound(brr, 2) + 2).EntireColumn.Cells(1, 1)
                If rTarget.Row + UBound(brr, 1) > rTarget.Parent.Rows.Count Then
                    Exit For
                End If
            End If
            
            For yb = LBound(arr) To UBound(arr)
                brr(yb, 1) = yc
                brr(yb, 2) = Join(arr(yb), ", ")
            Next
            Set rTarget = rTarget.Cells(1, 1).Resize(UBound(brr, 1), UBound(brr, 2))
            rTarget.Value = brr
            Set rTarget = rTarget.Cells(rTarget.Rows.Count + 2, 1)
        End If
    Next
    
End Sub

Option Explicit
'Private dtExit As Date
Private aSour As Variant
Private aIndx As Variant
Private aComb As Variant
Private dic As Dictionary

Private Sub CommandButton2_Click()
    Unload Me
End Sub

Private Sub TextBox1_Change()
    ChangeAddress
End Sub

Private Sub TextBox2_Change()
    ChangeAddress
End Sub

Private Sub TextBox4_Change()
    ChangeAddress
End Sub

Private Sub ChangeAddress()
    Dim rSour As Range
    On Error Resume Next
    Set rSour = Лист1.Range(Me.TextBox4.Value).Resize(TextBox2.Value, TextBox1.Value)
    If Err = 0 Then
        LabelAddress.Caption = rSour.Address(0, 0, xlA1)
        aSour = rSour.Value
    End If
    On Error GoTo 0
End Sub

Private Sub TextBox5_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
    If Not IsDate(TextBox5.Value) Then
        TextBox5.Value = "0:01:00"
        Cancel = True
    End If
End Sub

Private Sub TextBox5_Change()
    ThisWorkbook.Names("остановка_через").RefersToRange.Value = TextBox5.Text
End Sub

Private Sub UserForm_Initialize()
    TextBox5.Text = ThisWorkbook.Names("остановка_через").RefersToRange.Text
    ChangeAddress
End Sub

Private Sub CommandButton1_Click()
    Static dtExit As Date
    On Error Resume Next
    Application.OnTime EarliestTime:=dtExit, Procedure:="SetExitFlag", Schedule:=False
    On Error GoTo 0
    dtExit = Now + CDate(TextBox5.Text)
    exitFlag = False
    Application.OnTime dtExit, "SetExitFlag"
    
    Application.StatusBar = "Следующая остановка после " & Format(dtExit, "hh:mm:ss")
    Me.Hide
    Me.TextBox1.Enabled = False
    Me.TextBox2.Enabled = False
    Me.TextBox3.Enabled = False
    Me.TextBox4.Enabled = False
    
    If dic Is Nothing Then
        Set dic = New Dictionary
        ReDim aComb(1 To UBound(aSour, 2))
        Лист2.Cells.ClearContents
        Лист2.Select
    End If
    FindBestСombination
End Sub

Private Sub FindBestСombination()
    Do
        aIndx_Init
        GetUniqCountAndAddDic aIndx
        
        VaryIndexes
        
        If exitFlag Then
            Exit Do
        End If
        DoEvents
    Loop
    PrintResult aComb
    Me.Show
End Sub

Private Sub VaryIndexes()
    Dim xa As Long
    For xa = LBound(aIndx) To UBound(aIndx)
        'xa = WorksheetFunction.RandBetween(LBound(aIndx), UBound(aIndx))
        VaryIndex xa
    Next
End Sub

Private Sub VaryIndex(xa As Long)
    Dim cIndx As Variant
    cIndx = aIndx
    
    Dim loBo As Long, upBo As Long
    If xa = LBound(aIndx) Then
        loBo = 1
    Else
        loBo = cIndx(xa - 1) + 1
    End If
    If xa = UBound(aIndx) Then
        upBo = UBound(aSour, 1)
    Else
        upBo = cIndx(xa + 1) - 1
        If upBo > UBound(aSour, 1) - UBound(aIndx) + xa Then
            upBo = UBound(aSour, 1) - UBound(aIndx) + xa
        End If
    End If

    Dim yc As Long, optY As Long, curUniqCount As Long, optUniqCount As Long
    For yc = loBo To upBo
        cIndx(xa) = yc
        curUniqCount = GetUniqCountAndAddDic(cIndx)
        If optUniqCount < curUniqCount Then
            optUniqCount = curUniqCount
            optY = yc
        End If
        DoEvents
    Next
    If optY > 0 Then
        aIndx(xa) = optY
    End If
End Sub

Private Function GetUniqCountAndAddDic(cIndx As Variant) As Long
    Dim sIndx As String
    sIndx = Join(cIndx, " ")
    
    If dic.Exists(sIndx) Then
        GetUniqCountAndAddDic = dic(sIndx)
        Exit Function
    End If
    
    Dim curUniqCount As Long
    curUniqCount = CountUniq(cIndx, aSour)
    
    Dim combItem As Variant
    If IsEmpty(aComb(curUniqCount)) Then
        ReDim combItem(1 To 1)
    Else
        combItem = aComb(curUniqCount)
        ReDim Preserve combItem(1 To UBound(combItem) + 1)
    End If
    combItem(UBound(combItem)) = cIndx
    aComb(curUniqCount) = combItem
    dic(sIndx) = curUniqCount
    GetUniqCountAndAddDic = curUniqCount
End Function

Private Sub aIndx_Init()
    If IsEmpty(aIndx) Then
        ReDim aIndx(1 To TextBox3.Value)
    End If
    
    Dim xa As Long, ys As Long, loBo As Long, upBo As Long
    For xa = LBound(aIndx) To UBound(aIndx)
        loBo = ys + 1
        upBo = UBound(aSour, 1) - UBound(aIndx) + xa
        ys = WorksheetFunction.RandBetween(loBo, upBo)
        aIndx(xa) = ys
    Next
End Sub

Private Function CountUniq(aIndx As Variant, aSour As Variant) As Long
    Dim iInd As Long, iCount As Long, xs As Long, ys As Long
    Dim aDone As Variant
    ReDim aDone(1 To UBound(aSour, 2)) As Boolean
    
    For iInd = LBound(aIndx) To UBound(aIndx)
        ys = aIndx(iInd)
        If ys <= UBound(aSour, 1) Then
            For xs = 1 To UBound(aSour, 2)
                If aSour(ys, xs) = 1 Then
                    If Not aDone(xs) Then
                        aDone(xs) = True
                        iCount = iCount + 1
                    End If
                End If
            Next
        End If
    Next
    CountUniq = iCount
End Function

Private Sub PrintResult(aComb)
    Dim rTarget As Range
    Set rTarget = Лист2.Cells(1, 1)
    rTarget.Parent.UsedRange.ClearContents
    rTarget.Cells(1, 1).Resize(1, 3).Value = Array("Уникальных", "Коробки", Empty)
    Set rTarget = rTarget.Cells(2, 1)
    
    Dim yc As Long, yb As Long, arr As Variant, hrr As Variant, brr As Variant
    For yc = UBound(aComb) To LBound(aComb) Step -1
        If Not IsEmpty(aComb(yc)) Then
            arr = aComb(yc)
            ReDim brr(1 To UBound(arr), 1 To 2)
            If rTarget.Row + UBound(brr, 1) > rTarget.Parent.Rows.Count Then
                Set rTarget = rTarget.Cells(1, UBound(brr, 2) + 2).EntireColumn.Cells(1, 1)
                If rTarget.Row + UBound(brr, 1) > rTarget.Parent.Rows.Count Then
                    Exit For
                End If
            End If
            
            For yb = LBound(arr) To UBound(arr)
                brr(yb, 1) = yc
                brr(yb, 2) = Join(arr(yb), ", ")
            Next
            Set rTarget = rTarget.Cells(1, 1).Resize(UBound(brr, 1), UBound(brr, 2))
            rTarget.Value = brr
            Set rTarget = rTarget.Cells(rTarget.Rows.Count + 2, 1)
        End If
    Next
    
    rTarget.Parent.Parent.Saved = True
End Sub

Option Explicit
Private Const source_address = "C4:D13"
Private Const target_address = "I4:AF9"

Sub Заполнить_формулы()
    Dim rTarg As Range
    Set rTarg = Range(target_address)
    
    Dim rSour As Range
    Set rSour = Range(source_address)
    
    Dim aSour As Variant
    aSour = rSour.Value
    
    Dim ySour_yTarg As Variant
    ySour_yTarg = GetArrayCorrespondenceYTarget_ySource(rSour.Columns(0), rTarg.Columns(0))
    
    Dim targDates As Variant
    targDates = rTarg.Rows(0).Value
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    Dim yTarg As Long, xTarg As Long, ySour As Variant, monthEdges As Variant, targDateAddress As String
    For xTarg = 1 To rTarg.Columns.Count
        monthEdges = Array(targDates(1, xTarg), CDate(WorksheetFunction.EoMonth(targDates(1, xTarg), 0)))
        targDateAddress = rTarg.Cells(0, xTarg).Address(0, 0, xlA1)
        For yTarg = 1 To rTarg.Rows.Count
            FillCellFormula rTarg.Cells(yTarg, xTarg), ySour_yTarg(yTarg), monthEdges, aSour, rSour, targDateAddress
        Next
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Private Sub FillCellFormula(clTarg As Range, ySour_yTarg As Variant, monthEdges As Variant, aSour As Variant, rSour As Range, targDateAddress As String)
    If IsEmpty(ySour_yTarg) Then
ClearAndExit:
        clTarg.ClearContents
        clTarg.Interior.Color = RGB(242, 242, 242)
        Exit Sub
    End If
    
    Dim arr As Variant
    
    Dim sFormula As String, ySour As Variant, sBeg As String, sFin As String
    For Each ySour In ySour_yTarg
        If aSour(ySour, 1) <= monthEdges(1) Then
            If aSour(ySour, 2) >= monthEdges(0) Then
                If aSour(ySour, 1) > monthEdges(0) Then
                    sBeg = rSour.Cells(ySour, 1).Address(0, 0, xlA1)
                Else
                    sBeg = targDateAddress
                End If
                If aSour(ySour, 2) < monthEdges(1) Then
                    sFin = rSour.Cells(ySour, 2).Address(0, 0, xlA1)
                Else
                    sFin = "EoMonth(" & targDateAddress & ",0)"
                End If
                
                sFormula = aSour(ySour, 1) & aSour(ySour, 2)
                sFormula = "NETWORKDAYS(" & sBeg & "," & sFin & ",НеРабДни2)"
                AddArr arr, sFormula
            End If
        End If
    Next
    If IsEmpty(arr) Then GoTo ClearAndExit
    sFormula = "= " & Join(arr, "+")
    clTarg.Formula = sFormula
    
    If UBound(arr) > 1 Then
        clTarg.Interior.Color = RGB(255, 255, 100)
    End If
End Sub

Private Sub AddArr(arr As Variant, sFormula As String)
    If IsEmpty(arr) Then
        ReDim arr(1 To 1)
    Else
        ReDim Preserve arr(LBound(arr) To UBound(arr) + 1)
    End If
    arr(UBound(arr)) = sFormula
End Sub

Private Function GetArrayCorrespondenceYTarget_ySource(rSour As Range, rTarg As Range)
    Dim dicNamesY As Object
    Set dicNamesY = GetNamesYdic(rSour)
    
    Dim aTarg As Variant
    aTarg = rTarg.Value
    Dim res As Variant
    ReDim res(1 To UBound(aTarg, 1))
    
    Dim yt As Long
    For yt = 1 To UBound(res)
        If dicNamesY.Exists(aTarg(yt, 1)) Then
            res(yt) = dicNamesY(aTarg(yt, 1)).Keys()
        End If
    Next
    GetArrayCorrespondenceYTarget_ySource = res
End Function

Private Function GetNamesYdic(rSour As Range) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim arr As Variant
    arr = rSour.Value
    
    Dim ya As Long, sName As String
    For ya = 1 To UBound(arr, 1)
        sName = arr(ya, 1)
        If Not dic.Exists(sName) Then
            Set dic(sName) = CreateObject("Scripting.Dictionary")
        End If
        dic(sName)(ya) = Empty
    Next
    
    Set GetNamesYdic = dic
End Function

sub macro_01(control IRibbonControl)
    tt
End sub