module1 bit

Sub ShowDisplayForm()
    frmDisplay.Show

End Sub

Sub AON_Nodes_Algorithm()
    Dim numNodes As Integer, i As Integer

    'Takes input as the number of required nodes and displays the list of nodes
    'Includes a start (0) and finish (numNodes + 1) node
    numNodes = Worksheets("InputTable").Range("A2").End(xlDown)

    Worksheets("AON Nodes Table").Range("A1").Value = 0

    i = 0

    Do While i <= numNodes
        i = i + 1
        Worksheets("AON Nodes Table").Range("A1").Offset(i, 0).Value = i
    Loop

End Sub

Sub AON_Arcs_Algorithm()
    Dim numNodes As Integer, i As Integer, P() As Integer, sz As Integer
    numNodes = Worksheets("InputTable").Range("A2").End(xlDown)

    i = 0

    Do While i <= numNodes
        i = i + 1

        Call GetPred(Worksheets("InputTable").Range("A2"), P(), sz)
    Loop

End Sub

Sub AOA_Nodes_Algorithm()
    Dim numNodes As Integer, i As Integer
    numNodes = Worksheets("InputTable").Range("A2").End(xlDown)

    i = 0

    Do While i <= numNodes + 1
        Worksheets("AOA Nodes Table").Range("A2").Offset(i, 0) = i
        Worksheets("AOA Nodes Table").Range("A2").Offset(i, 1) = 2 * i + 1
        Worksheets("AOA Nodes Table").Range("A2").Offset(i, 2) = 2 * i + 2
        i = i + 1
    Loop

End Sub

Sub CreateProjectNetwork()
    Dim AOAarcs() As Integer, finishtime As Double, r As Range, numNodes As Integer, i As Integer
    Dim ES As Integer, LS As Integer, Critical As Integer, maxLS As Integer, r2 As Range


    Application.ScreenUpdating = False

    AOAarcs = GetAOAarcs()
    Call FormatSolverWorksheet(AOAarcs)
    finishtime = SolveProjectNetworkMin()
    Call GetMinValues
    finishtime = SolveProjectNetworkMax(finishtime)
    Call GetMaxValues

    'Create Gantt Chart
    Worksheets("Gantt Chart").Cells.Clear
    Set r = Worksheets("Solution Table").Range("A2")
    Set r2 = Worksheets("Gantt Chart").Range("A1")
    numNodes = Worksheets("Solution Table").Range("A2").End(xlDown)
    'Begin Filling Table
    r2.Offset(0, 0) = "Activity"
    r2.Offset(0, 1).Value = 1
    r2.Offset(0, 2).Value = 2

    'Set default values
    i = 1
    maxLS = 0

    'For each row in solution table (except end node), create gantt chart row
    Do While i < numNodes - 1
        r2.Offset(i, 0) = r.Offset(i, 0) 'Activity number
        ES = r.Offset(i, 1).Value
        LS = r.Offset(i, 2).Value
        If LS > maxLS Then
            maxLS = LS
        End If
        Critical = r.Offset(i, 5).Value

        'Select Area to be formatted
        Worksheets("Gantt Chart").Select
        Range(Range("A1").Offset(i, ES + 1), Range("A1").Offset(i, LS)).Select
        If Critical = 1 Then
            With Selection.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent3
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
        Else
            With Selection.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 49407
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
        End If
    i = i + 1
    Loop
    Worksheets("Gantt Chart").Select
    'Add top row number from 1 to the max finish time (end node)
    Range("B1:C1").AutoFill Destination:=Range(Range("B1"), Range("B1").Offset(0, maxLS - 1)), Type:=xlFillDefault

    Application.ScreenUpdating = True
End Sub

Sub FormatSolverWorksheet(AOAarcs() As Integer)
    Dim r As Range, r2 As Range, r3 As Range
    Dim i As Integer, conststr As String
    Dim numconst As Integer, numvar As Integer
    Dim begpos As Integer, endpos As Integer

    numconst = UBound(AOAarcs) - LBound(AOAarcs) + 1

    Worksheets("Project Network").Cells.Clear

    Set r = Worksheets("Project Network").Range("A2")

    'column titles
    r.Value = "Activity"
    r.Offset(0, 1) = "Begin"
    r.Offset(0, 2) = "End"
    r.Offset(0, 3) = "Time"

    'transfer AOAarcs array to worksheet
    For i = 1 To numconst
        r.Offset(i, 0) = AOAarcs(i - 1, 0)
        r.Offset(i, 1) = AOAarcs(i - 1, 1)
        r.Offset(i, 2) = AOAarcs(i - 1, 2)
        r.Offset(i, 3) = AOAarcs(i - 1, 3)
    Next i

    numvar = Application.WorksheetFunction.Max( _
               Range(r.Offset(1, 2), r.Offset(1, 2).End(xlDown)))

    Set r2 = Worksheets("Project Network").Range("D1")
    For i = 1 To numvar
        r2.Offset(0, i) = i
    Next i

    Call FormatTable(Range(r.Offset(-1, 0), r2.Offset(numconst + 1, numvar)), vbWhite)
    Call FormatTable(Range(r2.Offset(1, 1), r2.Offset(1, numvar)), vbYellow)
    Range(r2.Offset(1, 1), r2.Offset(1, numvar)).Name = "DecVar"

    'LHS coefficients
    For i = 1 To numconst
        r.Offset(i, 3 + r.Offset(i, 1)) = -1
        r.Offset(i, 3 + r.Offset(i, 2)) = 1
    Next i

    Set r3 = r2.Offset(1, numvar + 1)

    'objective formula
    r3.FormulaR1C1 = "=SUM(RC[-" & numvar & "]:RC[-1])"
    Call FormatTable(r3, vbGreen)
    r3.Name = "ObjFunc"

    'constraint formulas
    For i = 1 To numconst
        conststr = "=SUMPRODUCT(RC[-" & numvar & "]:RC[-1],R2C[-" & numvar & "]:R2C[-1])"
        r3.Offset(i, 0).FormulaR1C1 = conststr
    Next i
    Call FormatTable(Range(r3.Offset(1, 0), r3.Offset(numconst, 0)), vbCyan)
    Range(r3.Offset(1, 0), r3.Offset(numconst, 0)).Name = "LHSRef"
    Range(r.Offset(1, 3), r.Offset(numconst, 3)).Name = "RHSRef"

End Sub


Function SolveProjectNetworkMin()
    ' Check Tools>References ... Analytic Solver Platform 2014-R2 Type Library

    Dim PR As New RSP.Problem
    PR.Variables.Clear
    PR.Functions.Clear
    PR.Solver.SolverType = Solver_Type_Minimize

    Dim DV As New RSP.Variable
    DV.Init Range("DecVar")
    DV.NonNegative
    PR.Variables.Add DV

    Dim OBJ As New RSP.Function
    OBJ.Init Range("ObjFunc")
    OBJ.FunctionType = Function_Type_Objective
    PR.Functions.Add OBJ

    Dim CNST As New RSP.Function
    CNST.Init Range("LHSRef")
    CNST.Relation Cons_Rel_GE, Range("RHSRef")
    PR.Functions.Add CNST

    PR.Engine = PR.Engines("Standard LP/Quadratic")
    PR.Solver.Optimize (Solve_Type_Solve)

    Dim result As Integer
    result = PR.Solver.OptimizeStatus
    If result = 5 Then
        MsgBox "Problem infeasible."
    End If

    SolveProjectNetworkMin = Range("ObjFunc").Offset(0, -1)

    Worksheets("Project Network").Activate
End Function

Function SolveProjectNetworkMax(finishtime As Double)
    ' Check Tools>References ... Analytic Solver Platform 2014-R2 Type Library

    Dim PR As New RSP.Problem
    PR.Variables.Clear
    PR.Functions.Clear
    PR.Solver.SolverType = Solver_Type_Maximize

    Dim DV As New RSP.Variable
    DV.Init Range("DecVar")
    DV.NonNegative
    PR.Variables.Add DV

    Dim OBJ As New RSP.Function
    OBJ.Init Range("ObjFunc")
    OBJ.FunctionType = Function_Type_Objective
    PR.Functions.Add OBJ

    Dim CNST As New RSP.Function
    CNST.Init Range("LHSRef")
    CNST.Relation Cons_Rel_GE, Range("RHSRef")
    PR.Functions.Add CNST

    Dim CNST2 As New RSP.Function
    CNST2.Init Range("ObjFunc").Offset(0, -1)
    CNST2.Relation Cons_Rel_LE, finishtime
    PR.Functions.Add CNST2

    PR.Engine = PR.Engines("Standard LP/Quadratic")
    PR.Solver.Optimize (Solve_Type_Solve)

    Dim result As Integer
    result = PR.Solver.OptimizeStatus
    If result = 5 Then
        MsgBox "Problem infeasible."
    End If

    SolveProjectNetworkMax = Range("ObjFunc").Offset(0, -1)

    Worksheets("Project Network").Activate
End Function

Sub GetMinValues()
    Dim r As Range, r2 As Range, numvar As Integer, i As Integer
    Dim r3 As Range

    Worksheets("Solution Table").Cells.Clear
    Set r = Worksheets("Project Network").Range("D1")
    Set r2 = Range(r.Offset(0, 1), r.Offset(0, 1).End(xlToRight))
    numvar = Application.WorksheetFunction.Max(r2)
    Set r3 = Worksheets("Solution Table").Range("A1")
    r3.Value = "Activity"
    r3.Offset(0, 1) = "ES"
    r3.Offset(0, 2) = "EF"
    'Earlies start and Earliest finish

    'Two nodes for each activity
    For i = 1 To numvar / 2
        r3.Offset(i, 0) = i - 1
        r3.Offset(i, 1) = r.Offset(1, 2 * i - 1)
        r3.Offset(i, 2) = r.Offset(1, 2 * i)
    Next i

End Sub


Sub GetMaxValues()
    Dim r As Range, r2 As Range, numvar As Integer, i As Integer
    Dim r3 As Range

    Set r = Worksheets("Project Network").Range("D1")
    Set r2 = Range(r.Offset(0, 1), r.Offset(0, 1).End(xlToRight))
    numvar = Application.WorksheetFunction.Max(r2)
    Set r3 = Worksheets("Solution Table").Range("A1")
    r3.Offset(0, 3) = "LS"
    r3.Offset(0, 4) = "LF"
    r3.Offset(0, 5) = "Critical"

    For i = 1 To numvar / 2
        r3.Offset(i, 3) = r.Offset(1, 2 * i - 1)
        r3.Offset(i, 4) = r.Offset(1, 2 * i)
        If r3.Offset(i, 1) = r3.Offset(i, 3) Then
            'Earliest start is same at latest start, it's part of critical path
            r3.Offset(i, 5) = 1
        Else
            r3.Offset(i, 5) = 0
        End If
    Next i

End Sub


Function GetAOAarcs()
    Dim AONarcs() As Integer, AOAarcs() As Integer
    Dim numNodes As Integer, n2 As Integer, i As Integer, j As Integer, sz As Integer, sz2 As Integer
    Dim r As Range, rng As Range, IsPred() As Boolean, Pred() As Integer, checklist As String

    Set r = Worksheets("InputTable").Range("A1")
    numNodes = Range(r.Offset(1, 0), r.End(xlDown)).Rows.Count

    ReDim IsPred(numNodes)
    sz = 0
    For i = 1 To numNodes
        Set rng = r.Offset(i, 2)
        Call GetPred(rng, Pred, n2)
        For j = 0 To n2 - 1
            sz = sz + 1
            ReDim Preserve AONarcs(2, 1 To sz)
            Worksheets("AON Arcs Table").Range("A1").Offset(sz, 0) = Pred(j)
            Worksheets("AON Arcs Table").Range("A1").Offset(sz, 1) = i
            AONarcs(1, sz) = Pred(j)
            AONarcs(2, sz) = i
            IsPred(Pred(j)) = True
        Next j
    Next i


    For i = 1 To numNodes
        If Not IsPred(i) Then
            sz = sz + 1
            ReDim Preserve AONarcs(2, 1 To sz)
            Worksheets("AON Arcs Table").Range("A1").Offset(sz, 0) = i
            Worksheets("AON Arcs Table").Range("A1").Offset(sz, 1) = numNodes + 1
            AONarcs(1, sz) = i
            AONarcs(2, sz) = numNodes + 1
        End If
    Next i

    ReDim AOAarcs(numNodes + 1 + sz, 3)
    For i = 0 To numNodes + 1
        AOAarcs(i, 0) = i
        AOAarcs(i, 1) = 2 * i + 1
        AOAarcs(i, 2) = 2 * i + 2
        If i <> 0 And i <> numNodes + 1 Then
            AOAarcs(i, 3) = r.Offset(i, 3)
        Else
            AOAarcs(i, 3) = 0
        End If
    Next i


    sz2 = numNodes + 1
    For i = 1 To sz
        sz2 = sz2 + 1
        AOAarcs(sz2, 0) = -1
        AOAarcs(sz2, 1) = AOAarcs(AONarcs(1, i), 2)
        AOAarcs(sz2, 2) = AOAarcs(AONarcs(2, i), 1)
        AOAarcs(sz2, 3) = 0
    Next i

    checklist = ""
    For i = 0 To sz2
        If i <= Worksheets("InputTable").Range("A2").End(xlDown) + 1 Then
            Worksheets("AOA Arcs Table").Range("A2").Offset(i, 0) = i
        Else
            Worksheets("AOA Arcs Table").Range("A2").Offset(i, 0).Value = "D"
            Worksheets("AOA Arcs Table").Range("A2").Offset(i, 3) = 0
        End If
        Worksheets("AOA Arcs Table").Range("A2").Offset(i, 1) = AOAarcs(i, 1)
        Worksheets("AOA Arcs Table").Range("A2").Offset(i, 2) = AOAarcs(i, 2)

        If i = 0 Then
            Worksheets("AOA Arcs Table").Range("A2").Offset(i, 3) = 0
        ElseIf Not IsEmpty(Worksheets("InputTable").Range("A2").Offset(i - 1, 3)) Then
            Worksheets("AOA Arcs Table").Range("A2").Offset(i, 3) = Worksheets("InputTable").Range("A2").Offset(i - 1, 3)
        Else
            Worksheets("AOA Arcs Table").Range("A2").Offset(i, 3) = 0
        End If

    Next i

    GetAOAarcs = AOAarcs

End Function


Sub GetPred(r As Range, P() As Integer, sz As Integer)
    Dim str() As String, i As Integer, numNodes As Integer

    If r.Value = "-" Then
        ReDim P(1) As Integer
        P(0) = 0
        sz = 1
    Else
        str = Split(r, ",")
        numNodes = UBound(str) - LBound(str) + 1
        ReDim P(numNodes) As Integer

        For i = 0 To numNodes - 1
            If IsNumeric(str(i)) Then
                P(i) = CInt(str(i))
            Else
                MsgBox "Predecessors should be numeric values!"
                End
            End If
        Next i
        sz = numNodes
    End If

End Sub