Новости:

Новая редакция правил форума: 2.4. Если вопрос или ответ содержится во вложенном файле, все-равно кратко описывайте в сообщении вопрос или суть решения. Это необходимо, чтобы тему можно было найти через поиск.

Главное меню

Создать символьную формулу по формуле excel

Автор Akor, 05.06.2019, 10:24

« назад - далее »

Akor

Давно уже пытаюсь упростить жизнь и сделать возможным автоматическое преобразование excel-формулы в "циферно-буквенную".
Есть таблица следующего вида:

Обозначение |      Источник          | Величина
         t1                  задано                    1
         t2                  задано                    2
         t3                   t1+t2                     3
         t4          (t1+t2)/t3+(1/t3)        1,333

В случае наличия формулы в столбце "Величина", в соответствующей строке столбца "Источник" указывается формула в циферно-буквенном виде.
Подскажите, можно ли автоматизировать процесс написания формул в графе источник. Например, создать функцию, обрабатывающую excel формулу и заменяющую все ссылки с величин на обозначения.

boa

Здравствуйте,
c 2013-го Excel'я появились функции ISFORMULA(ЕФОРМУЛА) и FORMULATEXT(Ф.ТЕКСТ).
используйте их

Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

Akor

В вашем примере результатом является формула вида R1C1, а требуется получить формулу вида "t1+t2...".


P.S. в моем ЦНИИ excel не обновляли с 2010. (В принципе, формулу вида R1C1 я могу получить и через макрофункцию, но методы доступные для "древних" в приоритете)

boa

#3
[suspicious]Почему-то машину все хотят поновее и если машине 10 лет, то считается, что уже старая и надо обновить.
но ведь программное обеспечение устаревает быстрее, чем железо...[/suspicious]

вам не помешает использовать именованные диапазоны и тогда формула будет выглядеть так как вы захотите.
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

Akor

Спасибо за пример, но это не решает мою задачу в полном объеме. (Либо я чего-то не понимаю)

Представте себе расчет, состоящий не из 4 строк, а из 4000. Мне придется каждому обозначению присваивать соотвествующее имя в диспетчере имен. Это займет много времени.
Далее, в проекте появились изменения, часть обозначений изменилась. Но имена в диспетчере имен не наследуют изменения обозначений. Как итог - заново перепроверять все соответствия.

vikttur

Таблица соответствий символ/значение у Вас есть.
Макросом препарировать формулу, заменять символы на значения.

Akor

#6
Честно говоря, плохо понимаю о чем речь.
Написал макрос для этой задачи, не очень красивый, но работает. Для тех кто столкнулся с похожей задачей пригодится.

Sub test()

    stopsymbols = Array("+", "-", "/", "*", "^", "(", ")") 'стоп символы
    stopsymbols2 = Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "0") 'если в формуле есть цифры
    Dim s, s1, s2, s3 As String
    Dim element, element2 As Variant
   
    s = ActiveCell.FormulaLocal  'что там у нас в активной ячейке?
    s = Replace(s, "=", "")  'убрать =
    s = Replace(s, "D", "B") 'меняем с D на B
    s1 = Len(s)  'найти длину строки
    i = 0 'номер символа
    s3 = Empty
       
        While s1 >= i 'пока строка не закончилась
            i = i + 1  'счетчик строки
            k = 0
            si = Mid(s, i, 1)  'перебираем символы по одному
           
                For Each element In stopsymbols
                stopsymbol = element
                        If si = element Then 'попали на стоп-слово?
                            If s2 <> Empty Then
                                For Each element2 In stopsymbols2
                                stopsymbol2 = element2
                                    If s2 = element2 Then
                                        s3 = s3 & s2 & si
                                        s2 = Empty
                                    ElseIf s2 <> Empty Then
                                        s3 = s3 & Range(s2).Value & si
                                        s2 = Empty
                                    End If
                                 Next
                            Else
                                s3 = s3 & si
                            End If
                        Else            'нет
                            k = k + 1
                        End If
                Next
               
                If k = UBound(stopsymbols) + 1 Then
                    k = 0
                    s2 = s2 & si
                End If
               
        Wend
       
       
     
     ActiveCell.Offset(0, 1).Range("A1").Select
   
   
        If ActiveCell.Value = "" Then
            ActiveCell.Value = s3
        Else
            MsgBox ("Ячейка для вставки занята")
        End If
       
       
       
End Sub

boa

написал пользовательскую функцию
Function FormulaSubstitution(a As Range, OffsetColumn&)
'' Author:  boa
'' Written: 05.06.2019
'' Edited:
'  Description:         a - ячейка из которой надо извлечь формулу _
             OffsetColumn - смещение по колонкам (+/-) для получения подстановочного имени
    Dim sFormula$, i, sh As Worksheet, sSymbols(), MyArr
    Set sh = Application.Caller.Parent
    sSymbols = Array("=", "+", "-", "/", "*", "^", "(", ")", "{", "}", ";", "  ")
    If a.Formula = CStr(a.Value) Then FormulaSubstitution = "Задано": Exit Function
    sFormula = a.Formula
    For Each i In sSymbols
        sFormula = Replace(sFormula, i, " ")
    Next
    MyArr = Split(Trim(sFormula), " ")
    sFormula = a.Formula
    For Each i In MyArr
        If Not IsNumeric(i) Then _
            sFormula = Replace(sFormula, i, sh.Range(i).Offset(, OffsetColumn).Value)
    Next
    FormulaSubstitution = Mid(sFormula, 2)
'    или так
'    FormulaSubstitution = Replace(sFormula, "=", "")
End Function
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

Akor

Андрей, спасибо! Очень красивое решение, и работает лучше, например, когда в формуле сплошь числовые значения вида "1/777". А вот мой макрос такое не любит.
Осталось подумать как прикрутить функции вида cos/ln/log и пр. Как получится - выложу.

boa

Цитата: Akor от 05.06.2019, 19:33Очень красивое решение
Спасибо,

Цитата: Akor от 05.06.2019, 19:33
Осталось подумать как прикрутить функции вида cos/ln/log и пр.
да не вопрос ;)
Function FormulaSubstitution(a As Range, OffsetColumn&)
'' Author:  boa
'' Written: 05.06.2019
'' Edited:
'  Description:         a - ячейка из которой надо извлечь формулу _
             OffsetColumn - смещение по колонкам (+/-) для получения подстановочного имени
    Dim sFormula$, i, sh As Worksheet, sSymbols(), MyArr
    Application.Volatile True
    Set sh = Application.Caller.Parent
    sSymbols = Array("=", "+", "-", "/", "*", "^", "(", ")", "{", "}", ";", ".", ",", "  ")
    If a.Formula = CStr(a.Value) Then FormulaSubstitution = "Задано": Exit Function
    sFormula = a.Formula
    For Each i In sSymbols
        sFormula = Replace(sFormula, i, " ")
    Next
    MyArr = Split(Trim(sFormula), " ")
    sFormula = a.Formula
On Error Resume Next
    For Each i In MyArr
        If Not IsNumeric(i) Then _
            sFormula = Replace(sFormula, i, sh.Range(i).Offset(, OffsetColumn).Value)
    Next
    FormulaSubstitution = Mid(sFormula, 2)
'    или так
'    FormulaSubstitution = Replace(sFormula, "=", "")
End Function

Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

Akor

Цитата: Akor от 05.06.2019, 19:33
да не вопрос ;)

И этого достаточно? Да как так-то!?  А я ломал голову над тем, как сравнивить строку с массивом введенных алгебраических функций, не очень успешно...

Тестировал на примерах - все работает отлично, но есть одно НО. Range.Value возвращает значения игнорируя их регистр, т.е. если мы имеем величину вида t1 или tк, то получим t1 и tk соответственно

boa

Цитата: Akor от 06.06.2019, 11:12
Range.Value возвращает значения
И это так. На то оно и Value.
А формат ячейки, это уже другая история и не все так просто будет, но думаю это уже занадто переносить размер шрифта, цвет, курсив и т.п.
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра