Function coffeegrounds$(a)
' параметры:
' a - массив из шести _целых_ _положительных_ (проверять как оно будет с отрицательными - тяжко мне) чисел
' a(0)...a(4) - имеемое
' a(5) - желаемое
' возвращаемое значение:
'   выражение для получения желаемого из имеемого
'   или грустный смайлик

Dim k%, i%, ii%, iOK%
Dim sum2%, s$
    
    For k =  0  To  31 
        sum2 =  0 
        For i =  0  To  4 
            ii =  2  ^ ( 4  - i)
            sum2 = sum2 + (- 1 ) ^ ((k And ii) \ ii) * CInt(a(i))
        Next i
        
        If sum2 = CInt(a( 5 )) Then
               iOK =  1 : Exit For
        ElseIf sum2 > CInt(a( 5 )) Then
            If sum2 Mod CInt(a( 5 )) =  0  Then iOK = sum2 \ CInt(a( 5 )): Exit For
        End If
    Next k
    
    If iOK >  0  Then
        If (k And  16 ) \  16  =  0  Then s = a( 0 ) Else s = "- " & a( 0 )
        For i =  1  To  4 
            ii =  2  ^ ( 4  - i)
            s = s & vbCrLf & IIf(((k And ii) \ ii) =  0 , "+ ", "- ") & a(i)
        Next i
        If iOK >  1  Then s = s & vbCrLf & "/ " & iOK
        s = s & vbCrLf & "= " & a( 5 )
        coffeegrounds = s
    Else
        coffeegrounds = " :("
    End If
End Function

?coffeegrounds(array( 843 , 605 , 550 , 714 , 328 , 321 ))
 843 
+  605 
-  550 
+  714 
-  328 
/  4 
=  321 

?coffeegrounds(array( 843 , 605 , 550 , 714 , 328 , 324 ))
 :(

?coffeegrounds(array( 843 , 605 , 550 , 714 , 328 , 254 ))
-  843 
+  605 
-  550 
+  714 
+  328 
=  254 

Function coffeegrounds2$(a, b%)
' параметры:
' a - массив N (хоть два хоть двадцать) _целых_ _положительных_  чисел
'   a(0)...a(N-1) - исходные "даты"
' b - искомая "дата"
' возвращаемое значение:
'   выражение для получения искомой "даты" из массива исходных
'   или грустный смайлик в случае, если "операця прошла успешно, но пациент умер"
'   или 'некорректные данные', - если первый параметр не является массивом

Dim k&, k2&, i%, ii%, iOK%
Dim sum2&, s$, N%, N2

    If Not IsArray(a) Then coffeegrounds2 = "некорректные данные": Exit Function
    N = UBound(a)
    N2 =  2 & ^ N

' получение возможных "сумм" из элементов массива исходных дат
    For k =  0  To  2 & * N2 -  1 
        sum2 =  0 : ii = N2
        For i =  0  To N
            sum2 = sum2 + (- 1 ) ^ ((k And ii) \ ii) * CInt(a(i))
            ii = ii \  2 
        Next i
        
' проверка соответствия "суммы" искомой дате
        If sum2 = b Then
        ' найдено точное соответствие - устанавливаем флаг ( iOK ), запоминаем маску ( k2 ), выходим из цикла
               iOK =  1 : k2 = k: Exit For
        ElseIf sum2 >  0  And iOK =  0  Then
        ' точное соответствиие не найдено, "сумма" больше положительна, флаг iOK ещё не установлен

        ' определяем, можно ли получить искомую дану из суммы делением или умножением
        ' если можно - устанавливаем флаг ( iOK ), запоминаем маску ( k2 )
        '  (!) из цикла не выходим, - возможно существует "сумма" с точным соответствием до которой ещё не добрались
            If sum2 > b Then
                If sum2 Mod b =  0  Then iOK = sum2 \ b: k2 = k
            ElseIf sum2 < b Then
                If b Mod sum2 =  0  Then iOK = (- 1 ) * b \ sum2: k2 = k
            End If
        End If
    Next k

' если флаг iOK не установлен - сообщаем о неудаче
' иначе - формируем строку "формулы"
    If iOK =  0  Then
         coffeegrounds2 = " :("
    Else
        ' строки с +/- исходными датами
        ii =  2  ^ N
        s = a( 0 )
        If (k2 And ii) \ ii >  0  Then s = "- " & s
        For i =  1  To N
            ii = ii \  2 
            s = s & vbCrLf & IIf(((k2 And ii) \ ii) =  0 , "+ ", "- ") & a(i)
        Next i
        
        ' если использовалось деление или умножение
        If iOK >  1  Then
            s = s & vbCrLf & "/ " & iOK
        ElseIf iOK < - 1  Then
            s = s & vbCrLf & "x " & (- 1 ) * iOK
        End If
        
        s = s & vbCrLf & "= " & b
        coffeegrounds2 = s
    End If
End Function

?coffeegrounds2(array( 843 , 605 , 550 , 714 , 328 ),  321 )
 843 
+  605 
-  550 
+  714 
-  328 
/  4 
=  321 

Private Sub Command1_Click()
Dim dotv0 As Integer
Dim a%(), i%, ii%

Text1.Text = ""
' выходим если не задана искомая дата
If dotv.Text > "" Then dotv0 = Val(dotv.Text) Else Exit Sub

ReDim a( 5 )
For i =  1  To  6 
    With Me("d" & i)
    If .Text > "" Then a(ii) = Val(.Text): ii = ii +  1 
    End With
Next
' выходим если не задана ни одна исходная дата
If ii =  0  Then Exit Sub

ReDim Preserve a(ii -  1 )

Text1.Text = coffeegrounds2(a, dotv0)
End Sub

Function coffeegrounds4$(a, b%, minCoef%, maxCoef%)
' (!) проверка переданных параметров не производится
' параметры:
' a - массив N (хоть два хоть двадцать) _целых_ _положительных_  чисел
'   a(0)...a(N-1) - исходные "даты"
' b - искомая "дата"
' minCoef - минимальный коэффициент деления/умножения
' maxCoef - максимальный коэффициент деления/умножения
' возвращаемое значение:
'   выражение для получения искомой "даты" из массива исходных
'   или грустный смайлик в случае, если "операця прошла успешно, но пациент умер"
'   или 'некорректные данные', - если первый параметр не является массивом

Dim k&, k2&, i%, ii%, iOK%
Dim sum2&, s$, N%, N2

    If Not IsArray(a) Then coffeegrounds2 = "некорректные данные": Exit Function
    N = UBound(a)
    N2 =  2 & ^ N

' получение возможных "сумм" из элементов массива исходных дат
    For k =  0  To  2 & * N2 -  1 
        sum2 =  0 : ii = N2
        For i =  0  To N
            sum2 = sum2 + (- 1 ) ^ ((k And ii) \ ii) * CInt(a(i))
            ii = ii \  2 
        Next i
        
' проверка соответствия "суммы" искомой дате
        If sum2 = b Then
        ' найдено точное соответствие - устанавливаем флаг ( iOK ), запоминаем маску ( k2 ), выходим из цикла
               iOK =  1 : k2 = k: Exit For
        ElseIf sum2 >  0  And iOK =  0  Then
        ' точное соответствиие не найдено, "сумма" положительна, флаг iOK ещё не установлен

        ' определяем, можно ли получить искомую дану из суммы делением или умножением
        ' если можно - устанавливаем флаг ( iOK )
            If sum2 > b Then
                If sum2 Mod b =  0  Then iOK = sum2 \ b
            ElseIf sum2 < b Then
                If b Mod sum2 =  0  Then iOK = b \ sum2
            End If

            If iOK >  0  Then
        ' если "множитель" попадает в диапазон допустимых, запоминаем маску ( k2 )
        ' 	если производилось умножение, - меняем знак флага ( iOK )
        ' иначе сбрасываем флаг ( iOK )
        '  (!) из цикла не выходим, - возможно существует "сумма" с точным соответствием до которой ещё не добрались		
                If iOK >= minCoef And iOK <= maxCoef Then
                        k2 = k: If sum2 < b Then iOK = (- 1 ) * iOK
                Else:	iOK =  0 
                End If
            End If

        End If
    Next k

' если флаг iOK не установлен - сообщаем о неудаче
' иначе - формируем строку "формулы"
    If iOK =  0  Then
         coffeegrounds4 = " :("
    Else
        ' строки с +/- исходными датами
        ii =  2  ^ N
        s = a( 0 )
        If (k2 And ii) \ ii >  0  Then s = "- " & s
        For i =  1  To N
            ii = ii \  2 
            s = s & vbCrLf & IIf(((k2 And ii) \ ii) =  0 , "+ ", "- ") & a(i)
        Next i
        
        ' если использовалось деление или умножение
        If iOK >  1  Then
            s = s & vbCrLf & "/ " & iOK
        ElseIf iOK < - 1  Then
            s = s & vbCrLf & "x " & (- 1 ) * iOK
        End If
        
        s = s & vbCrLf & "= " & b
        coffeegrounds4 = s
    End If
End Function