Обработка формул - вынос общего множителя за скобки

[alex77755]

Вариант функции с примером вызова из процедуры. Так же работает как UDF
Исправил. Вроде корректно

Sub qwert()
    Dim s
    s = "0,14*5,5*0,62+0,17*11*0,54+0,17*11*0,54+0,14*7,5*0,67"
    s = s & "+0,14*7,5*0,67+0,1*4,74*0,67+0,14*2,2*0,7+0,17*4*0,8+"
    s = s & "0,17*3*0,75+0,17*3*0,75+0,17*1,5*0,75+0,14*7,5*0,67+0,14*7,5*0,67+"
    s = s & "0,35*15*0,57+0,8*11*0,54+0,24*4*0,8+0,24*4*0,8+0,24*4*0,8+"
    s = s & "0,14*5,5*0,62+0,14*5,5*0,62+0,14*5,5*0,62+0,14*5,5*0,62+"
    s = s & "0,14*11*0,54+0,14*2,2*0,7+0,14*3*0,75+0,14*1,5*0,75+0,14*3*0,75+"
    s = s & "0,14*3*0,75+0,14*3*0,75+0,14*7,5*0,67+0,14*11*0,54+0,14*7,5*0,67+"
    s = s & "0,14*11*0,54+0,8*11*0,54+0,14*0,75*0,88+0,17*15*0,57+0,14*0,75*0,88+"
    s = s & "0,17*15*0,57+0,17*5,5*0,62+0,14*7,5*0,67+0,17*5,5*0,62+0,17*5,5*0,62+"
    s = s & "0,17*2,2*0,7+0,17*2,2*0,7+0,17*2,2*0,7+0,17*2,2*0,7+0,17*2,2*0,7+"
    s = s & "0,35*1,1*0,75+0,14*7,5*0,67+0,14*3*0,75+0,14*3*0,75+0,14*11*0,54+"
    s = s & "0,14*11*0,54+0,14*3*0,75+0,14*3*0,75+0,14*0,75*0,88+0,14*0,75*0,88+"
    s = s & "0,17*3*0,75+0,17*2,2*0,7+0,8*5,5*0,62+0,35*20,16*1,73+"
    s = s & "0,35*20,16*1,73+0,35*20,16*1,73"
    Debug.Print Вынести_за_скобки(s)

End Sub

Function Вынести_за_скобки(s)
Dim r, c, m, max, nm, t, tt, ss, sr, i, ti
Dim u, uu, uuu, sl: Set sl = CreateObject("Scripting.Dictionary")
u = Split(s, "+") 'массив слагаемых
t = somn_max(u)

Do
    ss = ""
    For c = 0 To UBound(u)
        If InStr(1, u(c), t & "*") > 0 Then
            ti = Split(u(c), "*")
            For i = 0 To UBound(ti)
                If ti(i) = t Then
                    ti(i) = ""
                End If
            Next i
            tt = Replace(Join(ti, "*"), "**", "*")
            ss = ss & "+" & Replace(u(c), t & "*", "")
            u(c) = ""
               
            
       ElseIf InStr(1, u(c), t) > 0 Then
            ti = Split(u(c), "*")
            For i = 0 To UBound(ti)
                If ti(i) = t Then
                    ti(i) = ""
                End If
            Next i
            tt = Replace(Join(ti, "*"), "**", "*")
            ss = ss & "+" & Replace(u(c), t & "*", "")
            u(c) = ""
        End If
    Next
    
    If Len(ss) > 0 Then
        tt = Mid(ss, 2)
        If InStr(1, tt, "+") > 0 Then tt = "(" & tt & ")"
        tt = t & "*" & tt
        sr = IIf(Len(sr) = 0, tt, sr & "+" & tt)
    End If
    t = somn_max(u)
Loop While Len(t) > 0


Вынести_за_скобки = sr

End Function

Function somn_max(u)
    Dim r, c, m, max, nm, t, tt, ss, sr, i, ti
    Dim uu, uuu, sl: Set sl = CreateObject("Scripting.Dictionary")
    For r = 0 To UBound(u) 'подсчёт уникальных сомножителей
        If InStr(1, u(r), "*") > 0 Then
            uu = Split(u(r), "*")
            For c = 0 To UBound(uu)
                sl(uu(c)) = sl(uu(c)) + 1
            Next c
        End If
    Next r
    If sl.Count > 0 Then
    uuu = sl.keys ' массив сомножителей с частотой встречаемости
    ReDim m(UBound(uuu), 1)
    For r = 0 To UBound(uuu)
        m(r, 0) = sl(uuu(r))
        m(r, 1) = uuu(r)
    Next r
    
    For r = 0 To UBound(m) - 1 '
        If m(r, 0) > max Then max = m(r, 0): nm = r
    Next r
    somn_max = m(nm, 1)
    End If

End Function

результат:
0,14*(5,5*0,62+7,5*0,67+7,5*0,67+2, 2*0,7+7,5*0,67+7,5*0,67+5,5*0,62+5, 5*0,62+5,5*0,62+5,5*0,62+11*0,54+2, 2*0,7+3*0,75+1,5*0,75+3*0,75+3*0,75 +3*0,75+7,5*0,67+11*0,54+7,5*0,67+1 1*0,54+0,75*0,88+0,75*0,88+7,5*0,67 +7,5*0,67+3*0,75+3*0,75+11*0,54+11* 0,54+3*0,75+3*0,75+0,75*0,88+0,75*0 ,88)+0,17*(11*0,54+11*0,54+4*0,8+3* 0,75+3*0,75+1,5*0,75+15*0,57+15*0,5 7+5,5*0,62+5,5*0,62+5,5*0,62+2,2*0, 7+2,2*0,7+2,2*0,7+2,2*0,7+2,2*0,7+3 *0,75+2,2*0,7)+0,8*(11*0,54+0,24*4* 0,8+0,24*4*0,8+0,24*4*0,8+11*0,54+5 ,5*0,62)+0,35*(15*0,57+1,1*0,75+20, 16*1,73+20,16*1,73+20,16*1,73)+0,1* 4,74*0,67

[bdfy]

возможно не самым изящным способом, но проблему вчера все же решили. вот решение. всем спасибо

Option Explicit

Private Type xx
    a() As Variant
End Type

Function Сократить_мега_строку(ByVal REAL_QUERY As String)

    Dim col As Collection
    Set col = New Collection
    
    Dim REAL As String
    REAL = Replace(REAL_QUERY, " ", "") 'убираем пробелы
    REAL = Split(REAL, "=")(0) 'отрезаем до знака =
    
    
    
    '
    ' парсинг РЕАЛЬНОЙ СТРОКИ
    '
    
    Dim arr_parts() As String
    Dim xx_strings() As String
    
    arr_parts = Split(REAL, "+")
    
    Dim i&
    For i = 0 To UBound(arr_parts)
        
        Dim v, Final
        Final = ""
        v = arr_parts(i)
        
        Dim Pattern As String
        Pattern = "[0-9.,*]"
        Dim index&
        For index = 1 To Len(v)
            If Mid(v, index, 1) Like Pattern Then
                Final = Final & Mid(v, index, 1)
            End If
        Next
        v = Final
        
        xx_strings = Split(Trim(v), "*")
        
        col.Add xx_strings
    Next
    
    With col
    For i = 1 To .Count
        
        Dim j&
        For j = i + 1 To .Count
            col(i)(0) = My_Dbl(col(i)(0))
            col(i)(1) = My_Dbl(col(i)(1))
            col(i)(2) = My_Dbl(col(i)(2))
        Next
    Next
    End With
    
    
    '
    ' сортируем коллекцию по нулевому элементу
    '
    Dim vTemp As xx
    ReDim vTemp.a(0 To 2) As Variant
    
    If False Then
    With col
    For i = 1 To .Count - 1
        For j = i + 1 To .Count
            If .Item(i)(0) > .Item(j)(0) Then
                
                vTemp.a(0) = .Item(j)(0)
                vTemp.a(1) = .Item(j)(1)
                vTemp.a(2) = .Item(j)(2)
                
                .Remove j
                .Add vTemp.a, , i
            End If
        Next j
    Next i
    End With
    
    End If
    
    '
    ' коллекция уникальных множителей
    '
    Dim uniq_col As New Collection, prev$
    For i = 1 To col.Count
    On Error Resume Next
        If prev <> col(i)(0) Then
            uniq_col.Add col(i)(0), "key_" & col(i)(0)
            On Error GoTo 0
        End If
        prev = col(i)(0)
    Next i
    
    
    '
    ' проход по всем элементам для выноса первого параметра
    '
    Dim last_mult As String
    Dim current_total As String
    
    Dim mega_total As String
    
    
    For i = 1 To uniq_col.Count
    
        Dim find_str As String
        find_str = uniq_col(i)
        
        current_total = ""
        
        Dim k&
        For k = 1 To col.Count
            If col(k)(0) = find_str Then
                current_total = current_total + col(k)(1) + "*" + col(k)(2) + " + "
            End If
        Next k
        
            
        current_total = Trim(current_total)
        If Right(current_total, 1) = "+" Then
            current_total = Mid(current_total, 1, Len(current_total) - 1)
        End If
        
        current_total = Compress_String(current_total)
                
            
        If Len(current_total) <> 0 Then
            mega_total = mega_total + find_str & " * (" + current_total + ") + "
        End If
            

    Next
    
    
    '
    '
    '
    mega_total = Trim(mega_total)
    If Right(mega_total, 1) = "+" Then
        mega_total = Mid(mega_total, 1, Len(mega_total) - 1)
    End If
 
    
    '-----------------------------
    '
    ' возврат результата
    '
    '--------------------------------
    Сократить_мега_строку = Replace(mega_total, " ", "")
    
End Function


Function GetDecimalSeparator() As String
Static val_sep
    If IsEmpty(val_sep) Then
        val_sep = Format(0#, ".")
    End If
    GetDecimalSeparator = val_sep
End Function


Function My_Dbl(ByVal v As Variant) As Variant
    My_Dbl = Null
    If Len(v) > 0 Then
        Dim DEC_SEP As String * 1
        DEC_SEP = GetDecimalSeparator()
        v = Replace(v, ".", DEC_SEP)
        v = Replace(v, ",", DEC_SEP)

        My_Dbl = CDbl(v)
    End If
End Function


Function Compress_String(ByVal v As Variant)

            If Len(v) = 0 Then
                Compress_String = ""
                Exit Function
            End If
        
                '
                ' ужимаем одинаковые current_total -> same_total
                '
                Dim array_same() As String
                Dim subcol As Collection
                Set subcol = New Collection
                array_same = Split(v, "+")
                Dim j&
                For j = 0 To UBound(array_same)
                    subcol.Add Trim(array_same(j))
                Next
                
                'сортировка
                Dim tmp_str As String
                If False Then
                With subcol
                Dim k&
                For k = 1 To .Count - 1
                  On Error Resume Next
                    For j = k + 1 To .Count
                        If .Item(k) > .Item(j) Then
                            tmp_str = .Item(j)
                            .Remove j
                            .Add tmp_str, , k
                            On Error GoTo 0
                        End If
                    Next j
                Next k
                End With
                End If
                
                
                'коллекция без повторок
                Dim tmp_col As New Collection
                Dim prev
                For j = 1 To subcol.Count
                On Error Resume Next
                    If prev <> subcol(j) Then
                        tmp_col.Add subcol(j), "key_" & subcol(j)
                        On Error GoTo 0
                    End If
                    prev = subcol(j)
                Next
                
                
                
                
                ReDim RES(1 To tmp_col.Count, 1 To 2)
                For j = 1 To tmp_col.Count

                    Dim find_count&
                    find_count = 0
                    
                    For k = 1 To subcol.Count
                        If tmp_col(j) = subcol(k) Then
                            find_count = find_count + 1
                        End If
                    Next k
                    
                    RES(j, 1) = tmp_col(j)
                    RES(j, 2) = find_count
                Next
                                
                
                
                
                For j = 1 To tmp_col.Count
                    
                    Dim str, same_count, same_total
                    str = RES(j, 1)
                    same_count = RES(j, 2)
                    
                    If same_count = 1 Then
                        same_total = same_total & str & " + "
                    Else
                        same_total = same_total & same_count & "*" & str & " + "
                    End If
                    
                Next
                
            
                same_total = Trim(same_total)
                If Right(same_total, 1) = "+" Then
                    same_total = Mid(same_total, 1, Len(same_total) - 1)
                End If
                
                Compress_String = Trim(same_total)

End Function

[Aleksandr H.]

Так был кросспостинг?

[IgorGO]

Sub qwert()
  Dim s
  s = "0,14*5,5*0,62+100^(0,14*10)"      '(1)
  Debug.Print Вынести_за_скобки(s)
End Sub

результат = 0,14*(5,5*0,62+100^(10)) '(2)
осталось проверить на калькуляторе (1) и (2) это тождественные выражения или может нет!!!???
для многих, видимо, ответ очевиден и без калькулятора
всем удачи в деле сокращении арифметических выражений!

[alex77755]

а степень-то откуда взялась? в вопросе явно указан формат записи