Sub main()
    Dim arr() As Long, i As Long, sMin  As Long, sMax  As Long, sMinCell As Long, sMaxCell As Long
    Dim x As Variant, safeArrayInOut, tmr As Double, mGCD As Long, a As Long, b As Long, c As Long
    Dim arrSubsetIndex() As Long, sMaxArr() As Long
    Dim j As Long, n As Long, k As Long
    Dim arrIndex() As Long
    
    tmr = Timer
    'Columns("C:C").ClearContents
    safeArrayInOut = Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1)).Value
    sMinCell = [b1]
    sMaxCell = [b2]
    mGCD = safeArrayInOut(1, 1)
               
    n = UBound(safeArrayInOut)
    ReDim arr(n - 1)
    
   ' For Each x In safeArrayInOut
    For i = 0 To n - 1
        'n = n + 1
        a = CLng(safeArrayInOut(i + 1, 1))
        arr(i) = a
        b = mGCD
        While b > 0
            c = b
            b = a Mod b
            a = c
        Wend
        mGCD = a
    Next
    
    For i = 0 To n - 1
        arr(i) = arr(i) \ mGCD
    Next i
    sMin = sMinCell \ mGCD
    sMax = sMaxCell \ mGCD
 
    ReDim arrIndex(sMax) As Long
    If sMin > sMax Then sMin = sMax
    
    ReDim sMaxArr(n - 1) As Long
    If arr(0) > sMax Then sMaxArr(0) = sMax Else sMaxArr(0) = arr(0)
    For i = 1 To n - 1
        sMaxArr(i) = sMaxArr(i - 1) + arr(i)
        If sMaxArr(i) > sMax Then sMaxArr(i) = sMax
    Next i
    
    Do
        For i = 1 To n
            If arr(i - 1) > 0 And arr(i - 1) <= sMax Then
                For j = sMaxArr(i - 1) - arr(i - 1) To 1 Step -1
                    If arrIndex(j) > 0 Then
                        k = j + arr(i - 1)
                        If arrIndex(k) = 0 Then
                            arrIndex(k) = i
                            If k >= sMin Then Exit Do
                        End If
                    End If
                Next j
                k = arr(i - 1)
                If arrIndex(k) = 0 Then
                    arrIndex(k) = i
                    If k >= sMin Then Exit Do
                End If
            End If
        Next i
    Loop While False
    
    
    If k < sMin Then
        For k = sMin - 1 To 1 Step -1
            If arrIndex(k) > 0 Then Exit For
        Next k
    End If
    i = 0
    If k * mGCD < sMinCell Or k * mGCD > sMaxCell Then MsgBox "Решение не найдено": Exit Sub 'если не найдена сумма слагаемых в заданном диапазоне
    
    While k > 0
       ReDim Preserve arrSubsetIndex(0 To i) As Long
       arrSubsetIndex(i) = arrIndex(k)
       k = k - arr(arrIndex(k) - 1)
        i = i + 1
    Wend
     
    ReDim safeArrayInOut(1 To n, 1 To 1) As Variant
    For i = 0 To UBound(arrSubsetIndex)
    safeArrayInOut(arrSubsetIndex(i), 1) = arr(arrSubsetIndex(i) - 1) * mGCD
    Next i
    
    [c1].Resize(n) = safeArrayInOut
    Debug.Print (Timer - tmr) * 1000
    MsgBox "Миллисекунд: " & (Timer - tmr) * 1000
End Sub