'v3
Option Explicit
Private rSRLK As Range
Private aCur As Variant
Private aMax As Variant
Private aVal As Variant
Private bExit As Boolean
 
Sub Ïîäîáðàòü_øåñòåðíè()
    Dim sh As Worksheet
    Set sh = ActiveSheet
     
    Application.Calculation = xlCalculationManual
     
    Set rSRLK = sh.Range("B6:B9")
     
    ReDim aVal(1 To rSRLK.Rows.Count)
     
    Dim cellSRLK As Range, rVal As Range, yy As Long
    For Each cellSRLK In rSRLK
        Set rVal = GetValidationRange(cellSRLK)
        'Set rVal = rVal.Resize(3)
        yy = yy + 1
        aVal(yy) = rVal.Value
    Next
     
    Dim xCur As Long
    ReDim aCur(LBound(aVal) To UBound(aVal))
    For xCur = LBound(aCur) To UBound(aCur)
        aCur(xCur) = 1
    Next
    'aCur(4) = 20
     
    Dim diff As Variant, KR As Double, LS As Double, mE7 As Double, mF3 As Double
    mF3 = sh.Range("F3").Value
    bExit = False
    Do
        If bExit Then Exit Do
        If aVal(4)(aCur(4), 1) + aVal(3)(aCur(3), 1) > aVal(2)(aCur(2), 1) + 25 Then
            If aVal(4)(aCur(4), 1) + aVal(3)(aCur(3), 1) + aVal(1)(aCur(1), 1) > 226 Then
                If aVal(2)(aCur(2), 1) + aVal(1)(aCur(1), 1) > aVal(3)(aCur(3), 1) + 25 Then
                    If aVal(4)(aCur(4), 1) + aVal(3)(aCur(3), 1) > 96 Then
                        If aVal(2)(aCur(2), 1) + aVal(1)(aCur(1), 1) > 100 Then
                            KR = aVal(4)(aCur(4), 1) * aVal(2)(aCur(2), 1)
                            LS = aVal(3)(aCur(3), 1) * aVal(1)(aCur(1), 1)
                            mE7 = KR / LS
                            'PrintSRLK
'                            If WorksheetFunction.And(sh.Range("G13:G17")) Then
                                If IsEmpty(diff) Then diff = Abs(mF3 - mE7) + 1
                                If diff > Abs(mF3 - mE7) Then
                                    diff = Abs(mF3 - mE7)
                                    aMax = aCur
                                    PrintSRLK
                                    sh.UsedRange.Calculate
                                End If
'                            End If
                        End If
                    End If
                End If
            End If
        End If
        AddOne 1
        DoEvents
    Loop
     
    If Not IsEmpty(aMax) Then aCur = aMax
    PrintSRLK
     
    Application.Calculation = xlCalculationAutomatic
End Sub
 
Private Sub AddOne(xx As Long)
    If xx > UBound(aCur) Then
        bExit = True
    End If
    If bExit Then Exit Sub
     
    aCur(xx) = aCur(xx) + 1
    If aCur(xx) > UBound(aVal(xx)) Then
        'aCur(xx) = 1
        ResetIndexes xx
        If xx > 1 Then Application.StatusBar = Join(aCur, " ")
         
        AddOne xx + 1
    End If
End Sub
 
Private Sub PrintSRLK()
    Dim yy As Long, arr As Variant
    For yy = 1 To UBound(aCur)
        arr = aVal(yy)
        rSRLK.Cells(yy, 1).Value = arr(aCur(yy), 1)
    Next
End Sub
 
Private Function GetValidationRange(rr As Range) As Range
    Dim ss As String
    ss = rr.Validation.Formula1
    ss = Mid(ss, 2)
    Set GetValidationRange = rr.Parent.Range(ss)
End Function

Private Sub ResetIndexes(xMax As Long)
    Dim xx As Long
    For xx = LBound(aCur) To xMax
        aCur(xx) = LBound(aVal(xx))
    Next
End Sub