ПОМОГИТЕ!!!!!!!!!!!! VBA

[oksyxxl]

Люди!!! Хелп ми плиз! Срочно требуется написать программу-надстройку к Excel на любом из Visual языков. Есть такой предмет "Теория принятия решений", там мы проходим алгоритмы минимизации функций одной или нескольких переменных, если кто слышал есть такой метод Дихотомии нахождения минимума функций, так вот нужно его запрограммировать. Проще всего, конечно, это сделать на V.Basicе, так как он встроен Excel и может быть сохранен как надстройка. Исходник программы есть на языке С++, он рабочий и очень хорошо и правильно работает, можно попробовать как-то перевести его в VBA, но я, к сожалению, понятия не имею, как это сделать, так как с Visual языками не имела дела никогда. Буду признательна за любую помощь (если кто-то возьмется написать готова оплатить), бесплатно-буду очень благодарна, платно-цена договорная. Писать на ящик oksyxxl@mail.ru Оксане

[Amed]

А какие варианты аплаты?

[oksyxxl]

Варианты - денежный, пивной, какой предложишь (в пределах разумного) !!! Только очень очень надо написать!!! Просто до безумия. Насколько мне сказали друзья = у знатока это займет не больше дня!

[alibek]

У знатока может быть и займет не больше для, только знатоку нужно понять, что требуется.

Если есть требуемое на другом языке, не могла бы ты выложить здесь эту программу на псевдоязыке (описать алгоритм)?

[oksyxxl]

Обязательно вложу вечером, когда домой вернусь, обязательно расскажу, только возьмитесь кто-нибудь написать! Пожалуйста. Настолько безвыходного положения в моей жизни еще не было! (

[uhm]

Эх, ребяты... Извините, если кому заработок обломал
Все слишком просто.

Метод деления интервала пополам (метод дихотомии).
Этот метод позволяет исключать в точности половину интервала на каждой итерации.
Приведем описание поисковой процедуры, ориентированной на нахождение точки минимума функции f(x) в интервале (a,b).
Шаг1. Положить xm=(a+b)/2 и L=b-a.
Вычислить значение f(xm).
Шаг2. Положить x1=a+L/4 и x2=b-L/4.
Можно заметить, что точки x1,xm,x2 делят интервал (a,b) на четыре равные части.
Вычислить значения f(x1) и f(x2).
Шаг3. Сравнить f(x1) и f(xm).
(1) если f(x1)<f(xm), исключить интервал (xm,b), положив b=xm.
Средней точкой нового интервала поиска становится точка x1. Следовательно, необходимо положить xm=x1. Перейти к шагу 5.
(2) если f(x1)>=f(xm), перейти к шагу 4.
Шаг4. Сравнить f(x2) и f(xm).
(1) если f(x2)<f(xm),исключить интервал (a,xm), положив a=xm.
Т.к. средней точкой нового интервала становится точка x2, положить xm=x2.
Перейти к шагу 5.
(2) если f(x2)>=f(xm), исключить интервалы (a,x1) и (x2,b).
Положить a=x1 и b=x2.
(Заметим, что xm продолжает оставаться средней точкой нового интервала)
Перейти к шагу 5.
Шаг5. Вычислить L=b-a.
Если величина |L| мала, закончить поиск, в противном случае вернуться к шагу 2.

Программку накатал за 15 минут, не слишком ее тестировал, но, по идее, должна работать правильно. Вот текст:

Код: Выделить всё


Function f(x As Double) As Double
'Функция, для которой ищем минимум

    f = x * x
End Function

Function find(LOW As Double, HIGH As Double) As Double
'Ищет минимум функции f(x) на интервале [LOW,HIGH] с точностью EPS
'Метод дихотомии работает корректно, если функция f(x) имеет только
'один локальный минимум на отрезке [LOW,HIGH]

Const EPS = 0.001


Dim a As Double, b As Double, x1 As Double, x2 As Double, xm As Double, L As Double

a = LOW
b = HIGH

L = Abs(a - b)
xm = (a + b) / 2

While L > EPS
       
        x1 = a + L / 4
        x2 = b - L / 4
       
       
        If f(x1) < f(xm) Then
            b = xm
        ElseIf f(x2) < f(xm) Then
            a = xm
        Else
            a = x1
            b = x2
        End If
        L = Abs(a - b)
        xm = (a + b) / 2
Wend

find = xm

End Function



[uhm]

ЗЫ А постить сразу во все форумы - не надо. И так ответим.

[oksyxxl]

Я очень очень вам благодарна за помощь, я думаю это покатит, так как в нашей группеVBA почти никто не знает, хотя мне нужно было написать мето Дихотомии для как минимум двумерной функции. Не могли бы Вы дописать чуть-чуть, чтобы она была или фиксированно двумерная или с n размерностью: типа х1, х2, х3.... Вопрос: подскажите, пожалуйста, как из нее теперь сделать надстройку в Excel. Готова оплатить Вашу работу, только помогите, программу надо сдать 1 июня 2005 года. Очень признательна за то, что Вы откликнулись

[oksyxxl]

Уважаемые! Вот текст программы, которая работает, но на Си. Там реализуется метод Свена - получение отрезка локализации минимума и Золотого-сечения - нахождения этого минимума. (Это почти то же, что и Дихотомии). И расскажите, пожалуйста, как эту программу сделать надстройкой, чтобы все работало. Там нужно в EXCEL её ввести, потом как-то сохранить как... надстройка. И она должна появиться в списке станд. функции Excel, типа
Введите ф-лу: Указываем на ячейку с ф-лой
Введите нач зн-ие Х: Указываем на X или вводим вручную

[oksyxxl]

Вот

[uhm]

Если этот код рабочий, то перевести его на VB - дело нескольких минут. Там же в основном арифметика.

[oksyxxl]

Да, он рабочий! Можете проверить!
Только можно попросить перевести его сразу в файл с расширением .bas. Как Вас благодарить, милый uhm?

[alibek]

uhm, не соглашайся! Тебя коварно соблазняет злостная Сишница!

[uhm]

Я мультиязыковый Так что мне по фигу. Вот только, времени нет совершенно (у самого диплом горит). Но, если вдруг выдастся минутка, может, и переведу.

[oksyxxl]

Ну, пожалуйста, я не соблазняю! :Р Ну за что же меня так, я этого не заслужила! Видимо совсем нет добрых людей на белом свете - я разочаровалась!

[GSerg]

Делать мне нечего, что ли

Код: Выделить всё

Option Explicit

Private Const n As Long = 2
Private p() As Double, x0() As Double

Private k As Long, M As Double
Private xk(0 To n - 1) As Double

Private Function f(x() As Double)
  f = (x(1) - x(0) * x(0))
  f = f * f + 100 * (1 - x(0) * x(0))
End Function

Private Sub f1(ByVal alpha As Double, x0() As Double, p() As Double, xk() As Double, ByVal n As Long)
  For n = 0 To n - 1
    xk(n) = x0(n) + alpha * p(n)
  Next
End Sub

Private Function fun(ByVal alpha As Double) As Double
  Dim xxk(0 To n - 1) As Double
 
  f1 alpha, x0, p, xxk, n
  fun = f(xxk)
End Function

Private Function Sven(ByVal x1 As Double, ByRef a As Double, ByRef b As Double) As Long
  Dim x2 As Double, h As Double, c As Double
 
  k = 1
  h = 0.01 * Abs(x1)
  If h < 0.1 Then h = 0.1
 
  x2 = x1 + h
  If fun(x2) > fun(x1) Then h = -h
  x2 = x1 + h
 
  Do While fun(x2) < fun(x1)
    h = 2 * h
    x1 = x2
    x2 = x1 + h
    k = k + 1
  Loop
 
  a = x1 - h / 2
  b = x2
 
  If a > b Then
    c = b
    b = a
    a = c
  End If
 
  Sven = k
End Function

Private Function ZS(ByVal a As Double, ByVal b As Double, ByRef M As Double) As Long
  Dim x1 As Double, x2 As Double, e As Double
 
  k = 1
  x1 = a + 0.618 * Abs(b - a)
  e = 0.000001
 
  Do
    x2 = a + b - x1
    If x1 < x2 Then
      If fun(x1) < fun(x2) Then
        b = x2
      Else
        a = x1
        x1 = x2
      End If
    ElseIf x1 > x2 Then
      If fun(x1) < fun(x2) Then
        a = x2
      Else
        b = x1
        x1 = x2
      End If
    End If
   
    k = k + 1
  Loop While Abs(b - a) > e And k < 40
 
  M = (a + b) / 2
  ZS = k
End Function

Sub Main()
  Dim a As Double, b As Double
  Dim iter1 As Long, iter2 As Long, i As Long
 
  ReDim x0(0 To 1), p(0 To 1)
  x0(0) = 1.5: x0(1) = 2
  p(0) = 1: p(1) = 0
   
  iter1 = Sven(1, a, b)
  iter2 = ZS(a, b, M)
 
  f1 M, x0, p, xk, n
 
  MsgBox "na= " & CStr(a) & "      b= " & CStr(b)
  MsgBox "Число итераций k= " & CStr(k)
  MsgBox "Минимум M= " & CStr(M)
 
  For i = 0 To n - 1
    MsgBox "xk(" & CStr(i) & ")=" & xk(i)
  Next
End Sub

[oksyxxl]

Уважаемые мои, я Вам искренне благодарна за помощь, но хоть кто-нибудь мне объяснит, как это все присоединить к EXCEL. Дело в том, что мне помимо того, чтобы ее написать, нужно сделать её НАДСТРОЙКОЙ! Есть в Excel такая функция, т. е. мне нужно уже не программно задавать функцию, вот так. Т.Е. она должна работать примерно как "Поиск решения", который встроен в EXCEL. Как я могу всех отблагодарить?

[oksyxxl]

Основная загвоздка в том, что она должна работать так: вот есть макрос, который делает реализацию методом Свена и ЗС-2, я должна открывать Excel в списке формул стандартной f(x) на панели, где стандартные SUM, IF и др. выбрать функцию мою – например MIN (определенные пользователем), и она должна мне сказать выберите формулу – я должна указать на ячейку, где внесена эта ф-ция
Введите направление р(0) – указала на ячейку c числом
Введите направление p(1) – указала на ячейку с числом
Введите … Т.е начальное направление поиска, начальную точку и функцию я ввожу в ячейки Excel, затем запускать мою надстройку и она мне должна в той ячейке, где я выбрала “=MIN(formula, n, xk(n), p(n)), нажимаю Enter и она выводит мне M – тот самый минимум.