Option Explicit
Dim Variable_num, Row_count, Col_count, string_count, i, j, Var_count As Integer
Dim Row_num, Col_num, Slack_var, Check_num, Row_Adjust, shift_row As Integer
Dim Temp_num, Temp_char, Temp_name, problem As String
Dim Check_row, Check_col, Pivot_row, Pivot_col, NegSlack_col, temp As Integer
Dim Find_Row_Row, Find_Col_Col, Transform_Row, Transform_Col As Integer
'Inequ_dir will be false if less then, a
'     nd true if greater than
Dim First_run, Started_fill, Found_num, Inequ_dir, Match_found As Boolean
Dim Continue, Neg_slack, No_Solution As Boolean
Dim Variable_name() As Variant
Dim Simplex_array() As Single
Dim Temp_array, Temp_quotient, Quotient, Row_mult, Temp1, Temp2, Pivot_Element As Single
Dim current_char As String
Dim Lesson As String

Public Sub SimplexSolver()
    No_Solution = False
    First_run = True
    Started_fill = False
    Found_num = False
    shift_row =  0 
    string_count =  1 
    Variable_num =  0 
    Row_count =  1 
    problem = LCase(Cells(Row_count,  1 ).Value)
    current_char = get_char(problem, string_count)
    ReDim Variable_name( 1 , Len(problem) -  5 )


    Do While current_char <> ":" And current_char <> ";" And First_run = True
        string_count = string_count +  1 
        current_char = get_char(problem, string_count)
    Loop


    Do While Mid(problem, string_count,  1 ) <> ";"
        string_count = string_count +  1 
        current_char = get_char(problem, string_count)


        Do While IsNumeric(current_char) Or current_char = " " Or current_char = "(" Or current_char = ")"
            string_count = string_count +  1 
            current_char = get_char(problem, string_count)
        Loop
        ' Gathering variable name


        Do While current_char <> " " And current_char <> "+" And current_char <> "-" And current_char <> ";"
            Temp_name = Temp_name & current_char
            string_count = string_count +  1 
            current_char = get_char(problem, string_count)
            Started_fill = True
        Loop


        If Started_fill Then
            Variable_num = Variable_num +  1 
            Variable_name( 0 , Variable_num -  1 ) = Temp_name
            Temp_name = ""
            Started_fill = False
        End If
    Loop
    First_run = True
    Cells( 3 ,  3 ).FormulaR1C1 = "=COUNTA(C[-2])"
    Row_num = Cells( 3 ,  3 ).Value
    Cells( 3 ,  3 ).Value = ""
    Col_num = Variable_num + Row_num +  1 
    ' The simplex array will have Row_num ro
    '     ws
    ' and Col_num (number of variables + 1 s
    '     lack variable per inequation
    ' + 1 for the Max/Min value)
    ReDim Preserve Variable_name( 1 , Variable_num -  1 )
    ReDim Simplex_array(Row_num -  1 , Col_num -  1 )


    For Row_count =  1  To Row_num
        Temp_name = ""
        problem = LCase(Cells(Row_count,  1 ))
        string_count = InStr( 1 , problem, ":") +  1 
        Found_num = False
        Started_fill = False
        current_char = get_char(problem, string_count) 'get 1st char


        Do While current_char <> ";" 'check for end of line
            Temp_num = ""


            Do While Not IsNumeric(current_char)'check for + or - or space or inquality symbol
                'make sure the number has proper sign
                If current_char = "-" Then Temp_num = Temp_num & current_char
                'if 1st char is "+" or a space, ignore i
                '     t
                'but if it isn't, then its probably the 
                '     start of the variable name
                ' so make sure temp_num is 1


                If current_char <> "+" And current_char <> "-" Then
                    Exit Do
                End If
                string_count = string_count +  1 
                current_char = get_char(problem, string_count)
            Loop


            Do While IsNumeric(current_char)
                Found_num = True
                Temp_num = Temp_num & current_char
                string_count = string_count +  1 
                current_char = get_char(problem, string_count)
            Loop
            'if no number preceded the variable, the
            '     number is 1
            'keeping the negative from above if it i
            '     s negative
            If Not Found_num Then Temp_num = Temp_num & "1"
            'getting next char
            'current_char = get_char(problem, string
            '     _count)
            Found_num = False


            Do While current_char <> "+" And current_char <> "-" And current_char <> ";"
                If current_char <> " " Then Temp_name = Temp_name & current_char
                string_count = string_count +  1 
                current_char = get_char(problem, string_count)
                If current_char = "<" Or current_char = ">" Or current_char = "=" Then Exit Do
            Loop


            For Var_count =  0  To Variable_num -  1 


                If Temp_name = Variable_name( 0 , Var_count) Then
                    Simplex_array(Row_count -  1 , Var_count) = Temp_num
                    Temp_name = ""
                    Match_found = True
                    Exit For
                End If
            Next Var_count


            If current_char = "<" Or current_char = ">" Or current_char = "=" Then
                Temp_num = ""
                Inequ_dir = False
                If Mid(problem, string_count,  1 ) = ">" Or Mid(problem, string_count +  1 ,  1 ) = ">" Then Inequ_dir = True


                Do While Not IsNumeric(Mid(problem, string_count,  1 ))


                    If Mid(problem, string_count,  1 ) = "-" Then
                        Temp_num = Temp_num & Mid(problem, string_count,  1 )
                    End If
                    string_count = string_count +  1 
                    current_char = get_char(problem, string_count)
                Loop


                Do While IsNumeric(current_char)
                    Temp_num = Temp_num & Mid(problem, string_count,  1 )
                    string_count = string_count +  1 
                    current_char = get_char(problem, string_count)
                Loop
                Simplex_array(Row_count -  1 , Col_num -  1 ) = Temp_num
                Temp_num = ""
                Temp_name = ""
            End If
        Loop 'when done, the line has been parsed
        'fill up with slack variables and MAX co
        '     lumn


        If Not Inequ_dir Then
            Slack_var =  1 'if <= then sladck is 1
        Else
            Slack_var = - 1 ' if >= then slack is -1
        End If
        ' the slack variable is added in the row
        '     it belongs then in the column
        ' after the real variables (variable_num
        '     -1) + the number of the row
        ' it is on -1 (row_count - 1)


        If InStr( 1 , problem, ":") <>  0  Then
            Simplex_array(Row_count -  1 , Col_num -  2 ) = Slack_var
        Else
            Simplex_array(Row_count -  1 , Variable_num -  1  + Row_count -  1 ) = Slack_var
        End If
    Next


    Do While current_char <> ":" And current_char <> ";" And First_run = True
        string_count = string_count +  1 
        current_char = get_char(problem, string_count)
    Loop
    First_run = False
    problem = LCase(Cells( 1 ,  1 ).Value)


    If InStr( 1 , problem, "min") =  0  Then


        For Col_count =  0  To Variable_num -  1 
            Simplex_array( 0 , Col_count) = Simplex_array( 0 , Col_count) * - 1 
        Next Col_count
    End If


    For Row_count =  0  To Row_num -  2 


        For Col_count =  0  To Col_num -  1 
            Temp_array = Simplex_array(Row_count, Col_count)
            Simplex_array(Row_count, Col_count) = Simplex_array(Row_count +  1 , Col_count)
            Simplex_array(Row_count +  1 , Col_count) = Temp_array
        Next Col_count
    Next Row_count
    Print_Array
    Continue = False
    Check_num =  0 
    Check_col = Variable_num -  1 


    For Check_row =  0  To Row_num -  2 
        Neg_slack = False
        Check_col = Check_col +  1 


        If Simplex_array(Check_row, Check_col) <  0  Then


            For i =  0  To Row_num -  1 


                If i <> Check_row And Simplex_array(i, Check_col) <>  0  Then
                    Neg_slack = False
                    Exit For
                End If


                If i <> Check_row And Simplex_array(i, Check_col) =  0  Then
                    Neg_slack = True
                End If
            Next i
            NegSlack_col = Check_col
        End If


        If Neg_slack Then
            Negative_Slack
            If No_Solution Then Exit Sub
            Check_row = - 1 
            Check_col = Variable_num -  1 
        End If
    Next Check_row
    'Optimize Routine
    Continue = True


    Do While Continue
        Continue = False
        First_run = True
        Row_count = Row_num -  1 


        For Col_count =  0  To Col_num -  3 
            Temp1 = Simplex_array(Row_count, Col_count)


            If Temp1 <  0  And First_run Then
                Temp2 = Temp1
                First_run = False
                Continue = True
                Pivot_col = Col_count
            End If


            If Temp1 <  0  And Temp1 < Temp2 Then
                Temp2 = Temp1
                Continue = True
                Pivot_col = Col_count
            End If
        Next Col_count


        If Continue Then
            Transform_Array
            If No_Solution Then Exit Sub
        End If
    Loop
    'End of Optimize
    'Display Results


    For Col_count =  0  To Col_num
        Check_num =  0 
        Temp1 =  0 
        Temp2 =  0 


        If Col_count < Variable_num Or Col_count = Col_num -  2  Then


            For Row_count =  0  To Row_num -  1 


                If Simplex_array(Row_count, Col_count) <>  0  Then
                    Check_num = Check_num +  1 
                    Temp1 = Row_count
                    Temp2 = Simplex_array(Row_count, Col_count)
                End If
            Next Row_count


            If Check_num =  1  Then


                For Check_col =  0  To Col_num -  1 
                    Simplex_array(Temp1, Check_col) = Simplex_array(Temp1, Check_col) / Temp2
                Next Check_col
                If Col_count < Variable_num Then Variable_name( 1 , Col_count) = Simplex_array(Temp1, Col_num -  1 )
            End If
        End If
    Next Col_count
    Print_Array


    For Row_count =  0  To Variable_num -  1 
        If Variable_name( 1 , Row_count) = "" Then Variable_name( 1 , Row_count) = "0"
        Cells(shift_row +  1  + Row_count,  1 ).Value = Variable_name( 0 , Row_count) & " = " & Variable_name( 1 , Row_count)
    Next Row_count
    problem = LCase(Cells( 1 ,  1 ).Value)


    If InStr( 1 , problem, "min") =  0  Then
        Cells(shift_row +  1  + Row_count +  1 ,  1 ).Value = "Max = " & Simplex_array(Row_num -  1 , Col_num -  1 )
    Else: Cells(shift_row +  1  + Row_count +  1 ,  1 ).Value = "Min = " & Simplex_array(Row_num -  1 , Col_num -  1 ) * - 1 
    End If
    Exit Sub
    Assistant.Visible = True
    Assistant.Animation = msoAnimationGetAttentionMajor
End Sub


Sub Negative_Slack()
    'Begin of Negative_Slack


    For i =  0  To NegSlack_col


        If Simplex_array(Check_row, i) >  0  Then
            Continue = True
            Pivot_col = i
            Exit For
        Else: Continue = False
        End If
    Next i


    If Continue = False Then
        Cells(Row_num +  1 ,  1 ).Value = "No solution"
        No_Solution = True
        Exit Sub
    End If
    Transform_Array
    'End of Negative_Slack
End Sub


Sub Transform_Array()
    Find_Row


    If Not Match_found Then
        Cells( 1  + shift_row,  1 ).Value = "No Solution"
        No_Solution = True
        Exit Sub
    End If
    Pivot_Element = Simplex_array(Pivot_row, Pivot_col)


    For Transform_Row =  0  To Row_num -  1 
        'GoSub highlight_Pivot
        If Transform_Row = Pivot_row Then Cells(Transform_Row +  1  + shift_row,  1 ).Value = "Pivot Element = [" & Pivot_row +  1  & " , " & Pivot_col +  1  & "]"


        If Transform_Row <> Pivot_row Then
            Row_mult = Simplex_array(Transform_Row, Pivot_col)


            For Transform_Col =  0  To Col_num -  1 
                Simplex_array(Transform_Row, Transform_Col) = - 1  * Row_mult * Simplex_array(Pivot_row, Transform_Col) + Pivot_Element * Simplex_array(Transform_Row, Transform_Col)
            Next Transform_Col
            Cells(Transform_Row +  1  + shift_row,  1 ).Value = " - (" & Row_mult & ")R" & (Pivot_row +  1 ) & " + (" & Pivot_Element & ")R" & (Transform_Row +  1 )
        End If
    Next Transform_Row
    Cells(Transform_Row +  1  + shift_row +  1 ,  1 ).Value = Lesson
    Lesson = ""
    Print_Array
End Sub


Sub Find_Row()
    Match_found = False
    First_run = True


    For Find_Row_Row =  0  To Row_num -  2 


        If Simplex_array(Find_Row_Row, Pivot_col) <>  0  Then
            Temp_quotient = Simplex_array(Find_Row_Row, Col_num -  1 ) / Simplex_array(Find_Row_Row, Pivot_col)


            If Temp_quotient >=  0  And First_run Then
                Quotient = Temp_quotient
                Pivot_row = Find_Row_Row
                Match_found = True
                First_run = False
            End If


            If (Temp_quotient >=  0  And Temp_quotient < Quotient) Or (Temp_quotient = Quotient And Find_Row_Row = Check_row) Then
                If Temp_quotient = Quotient And Find_Row_Row = Check_row Then Lesson = Lesson & " Always choose row with negative slack if its equal to lowest Quotient"
                Quotient = Temp_quotient
                Pivot_row = Find_Row_Row
                Match_found = True
            End If
        End If ' not using cells with 0
        Temp_quotient =  0 
    Next Find_Row_Row
End Sub


Sub Print_Array()
    ' Print out Matrix


    For Row_count =  0  To Row_num -  1 


        For Col_count =  0  To Col_num -  1 
            Cells(Row_count +  1  + shift_row, Col_count +  2 ).Value = Simplex_array(Row_count, Col_count)
        Next Col_count
    Next Row_count
    shift_row = shift_row + Row_num +  3 
    'End of Print Array
End Sub


Function get_char(problem, string_count)


    Do While Mid(problem, string_count,  1 ) = " "
        string_count = string_count +  1 
    Loop
    get_char = Mid(problem, string_count,  1 )
End Function