Option Explicit
Private Const N_BOX = 3
Private Const N_PREDMET = 74
Private Const K_BOX = 50 '1000

Sub test()
    CloseEmptyWb
    FindBestСombination nBox:=N_BOX, rSource:=Лист1.Range("B2").Resize(K_BOX, N_PREDMET)
End Sub

Private Sub FindBestСombination(nBox As Long, rSource As Range)
    Dim aSour As Variant
    aSour = rSource.Value
    
    Dim aIndx As Variant, flagExit As Boolean
    ReDim aIndx(1 To nBox)
    Init_aIndx aIndx
    
    Dim aComb As Variant, combItem As Variant
    ReDim aComb(1 To UBound(aSour, 2))
    
    Dim dt As Date
    Dim curUniqCount As Long
    Do
        If Not HasDupies(aIndx) Then
            If IsIncreasing(aIndx) Then
                curUniqCount = CountUniq(aIndx, aSour)
                If IsEmpty(aComb(curUniqCount)) Then
                    ReDim combItem(1 To 1)
                Else
                    ReDim Preserve combItem(1 To UBound(combItem) + 1)
                End If
                combItem(UBound(combItem)) = aIndx
                aComb(curUniqCount) = combItem
            End If
        End If
        If dt < Now - TimeSerial(0, 0, 5) Then
            dt = Now
            Application.StatusBar = Left("Перебираю " & Join(aIndx, " "), 125)
        End If
        
        PlusOne aIndx, 1, flagExit, UBound(aSour, 1)
        If flagExit Then Exit Do
        DoEvents
    Loop
    PrintResult aComb, rSource
    
    Application.StatusBar = False
End Sub

Private Sub PrintResult(aComb, rSource As Range)
    Dim rTarget As Range
    Set rTarget = Workbooks.Add(1).Sheets(1).Cells(1, 1)
    rTarget.Cells(1, 1).Resize(1, 3).Value = Array("Уникальных", "Коробки", Empty)
    Set rTarget = rTarget.Cells(2, 1)
    
    Dim aSource As Variant
    aSource = rSource.Columns(0).Value
    
    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
            Application.StatusBar = "Вывожу " & yc
            arr = aComb(yc)
            ReDim brr(1 To UBound(arr), 1 To 3)
            If rTarget.Row + UBound(brr, 1) > rTarget.Parent.Rows.Count Then Exit For
            
            For yb = LBound(arr) To UBound(arr)
                hrr = GetHeader(arr(yb), aSource)
                brr(yb, 1) = yc
                brr(yb, 2) = Join(arr(yb), ", ")
                brr(yb, 3) = Join(hrr, ", ")
            Next
            Set rTarget = rTarget.Cells(1, 1).Resize(UBound(brr, 1), UBound(brr, 2))
            rTarget.Value = brr
            Application.Goto rTarget
            Set rTarget = rTarget.Cells(rTarget.Rows.Count + 1, 1)
        End If
    Next
    
    Application.Goto Cells(1, 1)
    rTarget.Parent.Parent.Saved = True
End Sub

Private Function GetHeader(arr As Variant, aSource As Variant) As Variant
    Dim hrr As Variant, yh As Long
    ReDim hrr(LBound(arr) To UBound(arr))
    yh = LBound(hrr) - 1
    
    Dim ya As Variant
    For Each ya In arr
        yh = yh + 1
        hrr(yh) = aSource(ya, 1)
    Next
    GetHeader = hrr
End Function

Private Function IsIncreasing(aIndx As Variant) As Boolean
    Dim xi As Long, hi As Long
    For xi = LBound(aIndx) To UBound(aIndx) - 1
        For hi = xi + 1 To UBound(aIndx)
            If aIndx(xi) >= aIndx(hi) Then
                IsIncreasing = False
                Exit Function
            End If
        Next
    Next
    IsIncreasing = True
End Function

Private Function HasDupies(aIndx As Variant) As Boolean
    Dim xi As Long, hi As Long
    For xi = LBound(aIndx) To UBound(aIndx) - 1
        For hi = xi + 1 To UBound(aIndx)
            If aIndx(xi) = aIndx(hi) Then
                HasDupies = True
                Exit Function
            End If
        Next
    Next
End Function

Private Sub PlusOne(aIndx As Variant, level As Long, flagExit As Boolean, maxIndex As Long)
    If flagExit Then Exit Sub
    If aIndx(level) < maxIndex Then
        aIndx(level) = aIndx(level) + 1
'        ShiftRight aIndx, level, flagExit, maxIndex, False
    Else
        If level < UBound(aIndx) Then
            Dim xi As Long
            For xi = LBound(aIndx) To level
                aIndx(xi) = 1 'xi
            Next
            
'            Dim flagPlus As Boolean
'            ShiftRight aIndx, level, flagExit, maxIndex, flagPlus
'
'            If flagPlus Or True Then
                PlusOne aIndx, level + 1, flagExit, maxIndex
'            End If
        Else
            flagExit = True
        End If
    End If
End Sub

'Private Sub ShiftRight(aIndx As Variant, level As Long, flagExit As Boolean, maxIndex As Long, flagPlus As Boolean)
'    Exit Sub
'    Dim xi As Long
'    For xi = level + 1 To UBound(aIndx)
'        If aIndx(xi) <= aIndx(xi - 1) Then
'            If aIndx(xi) < maxIndex Then
'                aIndx(xi) = aIndx(xi - 1) + 1
'                If xi = level + 1 Then
'                    flagPlus = True
'                End If
'            Else
'                flagExit = True
'                Exit Sub
'            End If
'        End If
'    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)
        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
    Next
    CountUniq = iCount
End Function

Private Sub Init_aIndx(aIndx As Variant)
    Dim iInd As Long
    For iInd = LBound(aIndx) To UBound(aIndx)
        aIndx(iInd) = 1 'iInd
    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
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