Option Explicit
'v2
Private Np As Byte
Private Const Nn = 7
Private flagExit As Boolean
Private dic As Object
Private rPrint As Range

Sub Вывести_формулы()
    Set rPrint = Range("H3")

    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    Dim yn As Byte
    For yn = 2 To 7
        Np = yn
        JobNp
    Next
    
    Application.Calculation = Application_Calculation
    Application.StatusBar = False
End Sub

Private Sub JobNp()
    Set dic = CreateObject("Scripting.Dictionary")
    Dim arr As Variant
    InitArr arr
    
    flagExit = False
    Do
        If flagExit Then Exit Do
        JobArr arr
        PlusOne arr, 1
        DoEvents
    Loop
    
    If dic.Count > 0 Then JobDic
End Sub

Private Sub PlusOne(arr As Variant, lvl As Byte)
    If lvl > UBound(arr) Then
        flagExit = True
    Else
        If arr(lvl) < Nn Then
            arr(lvl) = arr(lvl) + 1
        Else
            Dim xa As Long
            For xa = lvl To 1 Step -1
                If xa + 1 <= UBound(arr) Then
                    arr(xa) = arr(xa + 1) + 1
                Else
                    arr(xa) = 1
                End If
            Next
            PlusOne arr, lvl + 1
        End If
    End If
    
    Static dt As Date
    If Now - TimeSerial(0, 0, 1) > dt Then
        dt = Now
        Application.StatusBar = Format(dt, "hh:mm:ss") & " " & Np - 1 & "/7 Ждите..."
        Application.Goto rPrint
    End If
End Sub

Private Sub JobArr(arr As Variant)
    Dim brr As Variant, yb As Byte
    ReDim brr(LBound(arr) To UBound(arr))
    
    Dim ya As Byte
    For yb = LBound(arr) To UBound(arr) - 1
        For ya = yb + 1 To UBound(arr)
            If arr(yb) = arr(ya) Then Exit Sub
        Next
    Next
    
    For yb = LBound(arr) To UBound(arr)
        brr(yb) = WorksheetFunction.Small(arr, yb)
    Next
    
    Dim sKey As String
    sKey = Join(brr)
    If Not dic.Exists(sKey) Then dic.Add sKey, brr
End Sub

Private Sub JobDic()
    Dim arr As Variant
    ReDim arr(1 To 1, 1 To dic.Count)
    
    Dim xa As Byte, brr As Variant, frr As Variant, yb As Byte, yf As Byte, sf As String
    For xa = 1 To UBound(arr, 2)
        brr = dic.Items()(xa - 1)
        ReDim frr(1 To 2 * UBound(brr))
        yf = LBound(frr) - 1
        For yb = LBound(brr) To UBound(brr)
            yf = yf + 1
            frr(yf) = Columns(brr(yb)).Address(0, 0, xlA1)
            yf = yf + 1
            frr(yf) = frr(yf - 1)
        Next
        sf = Join(frr, ",")
        Debug.Print sf
        sf = "=COUNTIFS(" & sf
        sf = sf & ")"
        
        If rPrint.Column = rPrint.Parent.Columns.Count Then Exit For
        rPrint.Formula = sf
        Set rPrint = rPrint.Cells(1, 2)
    Next
End Sub

Private Sub InitArr(arr As Variant)
    ReDim arr(1 To Np)
    Dim ya As Byte
    For ya = LBound(arr) To UBound(arr)
        arr(ya) = 1
    Next
End Sub