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

bdfy · 07.06.2017, 16:36

Есть код (писался давно, возможно не мною). Смысл его в обработке текстовой строки формулы. Функция упрощает формулу. выносит общие множители за скобки, потом объединяет одинаковые слагаемые в скобках
Все это относительно неплохо работает когда это сумма попарно перемноженых элементов
Например выражание :
"0,3*28,22+0,3*28,22+0,3*28,22"
корректно обрабатывает в
0,3*(3*28,22)
А вот если выражение чуть сложние (множителей больше) уже ничего не получается

"0,17*15*0,57+0,17*5,5*0,62+0,17*3* 0,75"
а должно бы получится
0,17*(15*0,57+5,5*0,62+3*0,75)
Как исправить код чтобы работало вот с такими выражениями (когда перемножаемых чисел три, а не два ) ?

Код:

Sub test()
s = "0,17*15*0,57+0,17*5,5*0,62+0,17*3*0,75"
's = "0,3*28,22+0,3*28,22+0,3*28,22"
    Debug.Print выделить_множители(s)
End Sub
Function выделить_множители(ByVal s As String, Optional ByVal kv As Integer = 0) As String
's = "(0,17*2 + 0,17*2 + 0,17*4 + 0,65*4 + 0,65*4 + 0,17*7,5 + 0,17*2)"

'debug.print s
s = Replace(s, "(", "")
s = Replace(s, ")", "")


Dim m1(0 To 10, 0 To 200) As Variant 'массив элементов. по строкам множители, в строке элементы суммы
'Debug.Print s
s1 = Split(s, "+")

    For Each x In s1
        s2 = Split(x, "*")
        a = CStr(s2(0))
        b = CStr(s2(1))
        
        f = -1
        j = 0
        'ищем есть ли такой множитель. если да находим его строку
        For i = 0 To UBound(m1, 1)
           ' ''debug.print "просматриваем " & m1(i, 0) & "?" & a
            If ((a)) = (m1(i, 0)) Then
                ''debug.print "нашли" & a & " строка " & i
                f = i
                Exit For
            End If
            If m1(i, 0) = 0 Then
                j = i
                Exit For
            End If
        Next i
        
        If f = -1 Then
            ''debug.print "новый множ." & a & " строка " & j
            m1(j, 0) = a
            f = j
            k = 1
            'Exit Sub
        Else
            k = 0
            For i = 1 To UBound(m1, 2) 'ищем крайнее слагаемое в строке f
                If m1(f, i) = 0 Then
                    k = i
                    Exit For
                End If
            Next i
        End If
        ''debug.print f & "-" & k & " " & x
        m1(f, k) = CStr(b) '& "*" & CStr(c)
        
       ' ''debug.print
    Next x



''debug.print
s = ""
For i = 0 To UBound(m1, 1) 'по строкам по множителям
            If m1(i, 0) = 0 Then
                Exit For
            Else
                    s = s & m1(i, 0) & "*"
                    n = 0
                    s1 = ""
                    For j = 1 To UBound(m1, 2)
                       If m1(i, j) = 0 Then
                          Exit For
                       Else
                           s1 = s1 & m1(i, j) & "+"
                           n = n + 1
                       End If
                    Next j
                    
                    If Len(s1) > 0 Then s1 = Left(s1, Len(s1) - 1) 'плюс обрезаем
                  
                  Debug.Print "вынести_за_скобки " & s1
                  s4 = вынести_за_скобки(s1)
                 s = s & IIf(n > 1, "(", "") & s4 & IIf(n > 1, ")", "")
                 s = s & IIf(kv > 0, "^" & kv, "") & "+"
                ''debug.print s
            End If
Next i
    s = Left(s, Len(s) - 1) 'плюс обрезаем
     выделить_множители = s
     'debug.print s
End Function

Function вынести_за_скобки(ByVal s1 As String, Optional ByVal kv As Integer = 0) As String



    'ищем тут дупликаты в сумме
Dim m2(0 To 50, 0 To 1) As Single 'массив элементов. по строкам множители, в строке элементы суммы
Erase m2
s3 = ""
s3 = Split(s1, "+")
'ReDim m2(51, 2)

For Each x In s3
      
        f = -1
        j = 0
        'ищем есть ли такой множитель. если да находим его строку
       For t = 0 To UBound(m2, 1)
          '  ''debug.print "просматриваем " & m1(t, 0) & "?" & a
            If CSng(x) = (m2(t, 0)) Then
              'debug.print "нашли" & a & " строка " & t
                f = t
                m2(f, 1) = m2(f, 1) + 1
                Exit For
            End If
            If m2(t, 0) = 0 Then
                j = t
                Exit For
            End If
        Next t
    
            If f = -1 Then
                ''debug.print "новый множ." & a & " строка " & j
                m2(j, 0) = x
                m2(j, 1) = 1
                'Exit Sub
            End If
                    
       
   Next x
'''debug.print
    s4 = ""
    n = 0
    For k = 0 To UBound(m2, 1)
        If m2(k, 0) = 0 Then Exit For
        s4 = s4 & IIf(m2(k, 1) > 1, m2(k, 1) & "*", "") & m2(k, 0) & IIf(kv > 0, "^" & kv, "") & "+"
        n = n + 1
    Next k
   If Len(s4) > 0 Then s4 = Left(s4, Len(s4) - 1) 'плюс обрезаем
    ''debug.print "s4 " & s4
вынести_за_скобки = s4
End Function

Aleksandr H. · 08.06.2017, 09:43

Железно в каждом слагаемом есть множитель которого можно вынести за скобки?

bdfy · 08.06.2017, 10:10

Почти 99%.
более того как правило это слагаемое первый множитель.

Aleksandr H. · 08.06.2017, 10:22

Код:

Sub Brackets()
    Dim examples As String
    Dim InputLine() As String, LineCount As Byte
    Dim Parts() As String, subParts() As String
    Dim Comp() As String
    Dim Collect() As String
    Dim MaxLength As Integer
    Dim InRow As Byte, OutCol As Byte, InCol As Byte
    Dim i As Integer, str As String, j As Integer, colInd As Integer
    Dim helpStr As String
    Dim sFind As String
    Dim isInRow As Boolean, isInArray As Boolean
    
    examples = "0,17*15*0,57*0,1+0,17*5,5*0,62+0,17*3*0,75;" _
    & "0,17*15*0,57*0,1+0,17*15*0,62+15*3*0,17;" _
    & "0,3*28,22+0,3*28,22+0,3*28,22*17;" _
    & "0,3*28,22+0,31*28,2+0,32*2,22*17"
    
    InputLine = Split(examples, ";")
    For LineCount = LBound(InputLine) To UBound(InputLine)
        Comp = Split(InputLine(LineCount), "+")
        
        MaxLength = 0
        For i = 0 To UBound(Comp)
            helpStr = Comp(i)
            str = Replace(helpStr, "*", "")
            MaxLength = IIf(Len(helpStr) - Len(str) > MaxLength, Len(helpStr) - Len(str), MaxLength)
            ReDim Preserve Parts(UBound(Comp), MaxLength + 2 )
            subParts = Split(helpStr, "*")
            Parts(i, 0) = UBound(subParts) + 1
            For j = 0 To UBound(subParts)
                Parts(i, j + 1) = subParts(j)
            Next j
        Next i
        colInd = 0
        OutCol = 1
        Do While OutCol <= Parts(0, 0)
            sFind = Parts(0, OutCol)
            isInRow = False
            isInArray = True
            For InRow = 1 To UBound(Parts, 1)
                For InCol = 1 To Parts(InRow, 0)
                    helpStr = Parts(InRow, InCol)
                    If Parts(InRow, InCol) = sFind Then
                        isInRow = True
                        For i = InCol To Parts(InRow, 0)
                            Parts(InRow, i) = Parts(InRow, i + 1)
                        Next i
                        Parts(InRow, 0) = Parts(InRow, 0) - 1
                        isInRow = True: Exit For
                    End If
                Next InCol
                isInArray = isInArray And isInRow
                isInRow = False
            Next InRow
            If isInArray Then
                ReDim Preserve Collect(colInd)
                Collect(colInd) = sFind & "*"
                colInd = colInd + 1
                For i = OutCol To Parts(0, 0)
                    Parts(0, i) = Parts(0, i + 1)
                Next i
                Parts(0, 0) = Parts(0, 0) - 1
            Else
                OutCol = OutCol + 1
            End If
        Loop
        helpStr = Join(Collect, "")
        For InRow = 0 To UBound(Parts, 1)
            str = ""
            If Parts(InRow, 0) > 0 Then
                For InCol = 1 To WorksheetFunction.Max(0, Parts(InRow, 0) - 1)
                    str = str & Parts(InRow, InCol) & "*"
                Next InCol
                str = str + Parts(InRow, Parts(InRow, 0))
            Else
                str = str & "1"
            End If
            
            helpStr = helpStr & IIf(InRow = 0, "(", "+") & str
        Next InRow
        helpStr = IIf(Right(helpStr, 1) <> "*", helpStr & ")", Left(helpStr, Len(helpStr) - 1))
        helpStr = Replace(helpStr, "()", "")
        MsgBox "EXAMPLE " & LineCount & vbNewLine & InputLine(LineCount) & " = " & helpStr
        helpStr = ""
        str = ""
        ReDim Collect(0)
    Next LineCount
End Sub

bdfy · 08.06.2017, 11:15

здравствуйте. выглядит шикарно, но валится вот на таком стринге
"0,14*5,5*0,62+0,17*11*0,54+0,17*11 *0,54+0,14*7,5*0,67"
а вот он же полностью

Код:

0,14*5,5*0,62+0,17*11*0,54+0,17*11*0,54+0,14*7,5*0,67+0,14*7,5*0,67+0,1*4,74*0,67+0,14*2,2*0,7+0,17*4*0,8+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+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+0,14*5,5*0,62+0,14*5,5*0,62+0,14*5,5*0,62+0,14*5,5*0,62+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+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+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+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+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+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+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+0,17*3*0,75+0,17*2,2*0,7+0,8*5,5*0,62+0,35*20,16*1,73+0,35*20,16*1,73+0,35*20,16*1,73

Aleksandr H. · 08.06.2017, 11:27

Значит надо посмотреть

В чем валится, когда. Вам же сложно привести код что есть, что должно получиться, в чем именно "валка".

Вижу 0,14 потерялось

bdfy · 08.06.2017, 11:39

Код:

Sub test2432()
    Dim examples As String
    Dim InputLine() As String, LineCount As Byte
    Dim Parts() As String, subParts() As String
    Dim Comp() As String
    Dim Collect() As String
    Dim MaxLength As Integer
    Dim InRow As Byte, OutCol As Byte, InCol As Byte
    Dim i As Integer, str As String, j As Integer, colInd As Integer
    Dim helpStr As String
    Dim sFind As String
    Dim isInRow As Boolean, isInArray As Boolean
    
    'examples = "0,17*15*0,57*0,1+0,17*5,5*0,62+0,17*3*0,75;" _
    & "0,17*15*0,57+0,17*15*0,62+0,17*3*0,17;" _
    & "0,3*28,22+0,3*28,22+0,3*28,22*17;" _
    & "0,3*28,22+0,31*28,2+0,32*2,22*17;"
    examples = "0,14*5,5*0,62+0,17*11*0,54+0,17*11*0,54+0,14*7,5*0,67"
    
    InputLine = Split(examples, ";")
    For LineCount = LBound(InputLine) To UBound(InputLine)
        Debug.Print Brackets(InputLine(LineCount))
    Next LineCount
    
s = "0,14*5,5*0,62+0,17*11*0,54+0,17*11*0,54+0,14*7,5*0,67" ' +0,14*7,5*0,67+0,1*4,74*0,67+0,14*2,2*0,7+0,17*4*0,8+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+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+0,14*5,5*0,62+0,14*5,5*0,62+0,14*5,5*0,62+0,14*5,5*0,62+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+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+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+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+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+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+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+0,17*3*0,75+0,17*2,2*0,7+0,8*5,5*0,62+0,35*20,16*1,73+0,35*20,16*1,73+0,35*20,16*1,73"
'Debug.Print Brackets(s)

End Sub
Sub Brackets() '(ByVal InputLine As String)
InputLine = "0,14*5,5*0,62+0,17*11*0,54+0,17*11*0,54+0,14*7,5*0,67"
'InputLine = "0,17*15*0,57+0,17*15*0,62+0,17*3*0,17"
    Dim examples As String
    Dim LineCount As Byte
    Dim Parts() As String, subParts() As String
    Dim Comp() As String
    Dim Collect() As String
    Dim MaxLength As Integer
    Dim InRow As Byte, OutCol As Byte, InCol As Byte
    Dim i As Integer, str As String, j As Integer, colInd As Integer
    Dim helpStr As String
    Dim sFind As String
    Dim isInRow As Boolean, isInArray As Boolean
    
        Comp = Split(InputLine, "+")
        
        MaxLength = 0
        For i = 0 To UBound(Comp)
            helpStr = Comp(i)
            str = Replace(helpStr, "*", "")
            MaxLength = IIf(Len(helpStr) - Len(str) > MaxLength, Len(helpStr) - Len(str), MaxLength)
            ReDim Preserve Parts(UBound(Comp), MaxLength + 2)
            subParts = Split(helpStr, "*")
            Parts(i, 0) = UBound(subParts) + 1
            For j = 0 To UBound(subParts)
                Parts(i, j + 1) = subParts(j)
            Next j
        Next i
        colInd = 0
        OutCol = 1
        Do While OutCol <= Parts(0, 0)
            sFind = Parts(0, OutCol)
            isInRow = False
            isInArray = True
            For InRow = 1 To UBound(Parts, 1)
                For InCol = 1 To Parts(InRow, 0)
                    helpStr = Parts(InRow, InCol)
                    If Parts(InRow, InCol) = sFind Then
                        isInRow = True
                        For i = InCol To Parts(InRow, 0)
                            Parts(InRow, i) = Parts(InRow, i + 1)
                        Next i
                        Parts(InRow, 0) = Parts(InRow, 0) - 1
                        isInRow = True: Exit For
                    End If
                Next InCol
                isInArray = isInArray And isInRow
                isInRow = False
            Next InRow
            If isInArray Then
                ReDim Preserve Collect(colInd)
                Collect(colInd) = sFind & "*"
                colInd = colInd + 1
                For i = OutCol To Parts(0, 0)
                    Parts(0, i) = Parts(0, i + 1)
                Next i
                Parts(0, 0) = Parts(0, 0) - 1
            Else
                OutCol = OutCol + 1
            End If
        Loop
        helpStr = Join(Collect, "")
        For InRow = 0 To UBound(Parts, 1)
            str = ""
            If Parts(InRow, 0) > 0 Then
                For InCol = 1 To WorksheetFunction.Max(0, Parts(InRow, 0) - 1)
                    str = str & Parts(InRow, InCol) & "*"
                Next InCol
                str = str + Parts(InRow, Parts(InRow, 0))
            Else
                str = str & "1"
            End If
            
            helpStr = helpStr & IIf(InRow = 0, "(", "+") & str
        Next InRow
        helpStr = IIf(Right(helpStr, 1) <> "*", helpStr & ")", Left(helpStr, Len(helpStr) - 1))
        helpStr = Replace(helpStr, "()", "")
      '  Brackets = helpStr
        
        Debug.Print "EXAMPLE " & helpStr
        helpStr = ""
        str = ""
        ReDim Collect(0)
        

End Sub

InputLine = "0,14*5,5*0,62+0,17*11*0,54+0,17*11 *0,54+0,14*7,5*0,67"
Результат
EXAMPLE (0,14*5,5*0,62+0,17*11*0,54+0,17*11 *0,54+7,5*0,67)
т.е почти тоже самое только без посл. 0,14
хотя должно было бы быть
"0,14*(5,5*0,62+7,5*0,67)+0,17*(11* 0,54+11*0,54)"
а в идеале даже
"0,14*(5,5*0,62+7,5*0,67)+0,17*(2*1 1*0,54)"

Aleksandr H. · 08.06.2017, 11:58

Цитата:

Сообщение от Aleksandr H.

Железно в каждом слагаемом есть множитель которого можно вынести за скобки?

Цитата:

Сообщение от bdfy

Почти 99%.

Цитата:

Сообщение от bdfy

InputLine = "0,14*5,5*0,62+0,17*11*0,54+0,1 7*11 *0,54+0,14*7,5*0,67"
Результат
должно было бы быть
"0,14*(5,5*0,62+7,5*0,67)+0,17* (11* 0,54+11*0,54)"

Тут я пас. Группировать по подгруппах не буду. Удачи в решении.

Код:

Sub Brackets()
    Dim examples As String
    Dim InputLine() As String, LineCount As Byte
    Dim Parts() As String, subParts() As String
    Dim Comp() As String
    Dim Collect() As String
    Dim MaxLength As Integer
    Dim InRow As Byte, OutCol As Byte, InCol As Byte
    Dim i As Integer, str As String, j As Integer, colInd As Integer, inCol_a As Integer
    Dim helpStr As String
    Dim sFind As String
    Dim isInRow As Boolean, isInArray As Boolean
    
    examples = "0,17*15*0,57*0,1+0,17*15*0,62+15*3*0,17"
    '"0,14*5,5*0,62+0,17*11*0,54+0,17*11*0,54+0,14*7,5*0,67;" _
    '& "0,17*15*0,57*0,1+0,17*15*0,62+15*3*0,17"
    '& "0,3*28,22+0,3*28,22+0,3*28,22*17;" _
    '& "0,3*28,22+0,31*28,2+0,32*2,22*17"
    
    InputLine = Split(examples, ";")
    For LineCount = LBound(InputLine) To UBound(InputLine)
        Comp = Split(InputLine(LineCount), "+")
        
        MaxLength = 0
        For i = 0 To UBound(Comp)
            helpStr = Comp(i)
            str = Replace(helpStr, "*", "")
            MaxLength = IIf(Len(helpStr) - Len(str) > MaxLength, Len(helpStr) - Len(str), MaxLength)
            ReDim Preserve Parts(UBound(Comp), MaxLength + 3)
            subParts = Split(helpStr, "*")
            Parts(i, 0) = UBound(subParts) + 1
            For j = 0 To UBound(subParts)
                Parts(i, j + 1) = subParts(j)
            Next j
        Next i
        
        colInd = 0
        OutCol = 1
        Do While OutCol <= Parts(0, 0)
            sFind = Parts(0, OutCol)
            isInRow = False
            isInArray = True
            For InRow = 1 To UBound(Parts, 1)
                For InCol = 1 To Parts(InRow, 0)
                    helpStr = Parts(InRow, InCol)
                    If Parts(InRow, InCol) = sFind Then
                        isInRow = True
                        Exit For
                    End If
                Next InCol
                isInArray = isInArray And isInRow
                isInRow = False
            Next InRow
            If isInArray Then
                ReDim Preserve Collect(colInd)
                Collect(colInd) = sFind & "*"
                colInd = colInd + 1
                For InRow = 0 To UBound(Parts, 1)
                    For InCol = 1 To Parts(InRow, 0)
                        If Parts(InRow, InCol) = sFind Then
                           For i = InCol To Parts(InRow, 0)
                            Parts(InRow, i) = Parts(InRow, i + 1)
                           Next i
                            Parts(InRow, 0) = Parts(InRow, 0) - 1
                            Exit For
                        End If
                    Next InCol
                    
                Next InRow
                
            Else
                OutCol = OutCol + 1
            End If
        Loop
        helpStr = Join(Collect, "")
        For InRow = 0 To UBound(Parts, 1)
            str = ""
            If Parts(InRow, 0) > 0 Then
                For InCol = 1 To WorksheetFunction.Max(0, Parts(InRow, 0) - 1)
                    str = str & Parts(InRow, InCol) & "*"
                Next InCol
                str = str + Parts(InRow, Parts(InRow, 0))
            Else
                str = str & "1"
            End If
            
            helpStr = helpStr & IIf(InRow = 0, "(", "+") & str
        Next InRow
        helpStr = IIf(Right(helpStr, 1) <> "*", helpStr & ")", Left(helpStr, Len(helpStr) - 1))
        helpStr = Replace(helpStr, "()", "")
        MsgBox "EXAMPLE " & LineCount & vbNewLine & InputLine(LineCount) & " = " & helpStr
        helpStr = ""
        str = ""
        ReDim Collect(0)
        Sheets(1).Cells(1, 1) = helpStr
    Next LineCount
End Sub

bdfy · 08.06.2017, 12:27

Цитата:

Железно в каждом слагаемом есть множитель которого можно вынести за скобки?

очевидно я вопрос понял как есть ли общие множители вообще, а не один ли множитель на все слагаемые

все равно огромное спасибо за помощь - будем сражаться дальше

IgorGO · 08.06.2017, 14:31

Цитата:

Железно в каждом слагаемом есть множитель которого можно вынести за скобки?

отвечу за автора:
железно, что в выражении написанном пользователем может быть что угодно! проанализируйте, есть - выносите, нет - оставьте все как есть

я так понимаю на входе - арифметическое выражение состоящее из чисел, пробелов, скобок и знаков арифметических действий
на выходе нужно получить тождественное выражание, но записанное более компактно!

удачи!

08.06.2017, 09:43	#2
Aleksandr H. 2 the Nation Glory Старожил Регистрация: 27.05.2014 Сообщений: 3,289	Железно в каждом слагаемом есть множитель которого можно вынести за скобки? Кто умер, но не забыт, тот бессмертен. Лао-Цзы.

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Проект Delphi, обработка формул и постоение графиков.	Wolfiron	Общие вопросы Delphi	4	05.04.2014 11:16
написать программу.Определить, корректно ли расставлены в строке круглые и квадратные скобки. Скобки могут быть вложенными	цезарь	Общие вопросы по Java, Java SE, Kotlin	3	22.06.2013 01:29
Составление рекуррентного множителя	Logannn	Помощь студентам	0	28.12.2012 01:55
Обработка запрсов содержащих скобки для ADO.Query	sergey113	Помощь студентам	1	26.05.2011 12:37
нахождение наибольшего общего делителя и наименьшего общего кратного	made in russia	Помощь студентам	2	21.12.2008 23:36

08.06.2017, 10:10	#3
bdfy Форумчанин Регистрация: 12.11.2009 Сообщений: 258	Почти 99%. более того как правило это слагаемое первый множитель.