SchedulingAlgorithms.bas

Attribute VB_Name = "SchedulingAlgorithms"
' Manufacturing Workflow Scheduler - Advanced Scheduling Algorithms Module
' Created: April 2025
'
' This module contains advanced scheduling algorithms for handling
' complex non-linear manufacturing workflows with divergence and convergence points

Option Explicit

' Constant definitions
Private Const MAX_ITERATIONS As Long = 100
Private Const OPTIMIZATION_THRESHOLD As Double = 0.01

' Main function to generate optimized schedule for complex workflows
Public Function GenerateOptimizedSchedule(workOrders As Collection, workflowSteps As Collection, _
                                         startDate As Date, workingHoursPerDay As Double, _
                                         useCalendarDays As Boolean) As Collection
    ' Initialize schedule collection
    Dim schedule As New Collection
    
    ' Process each work order through advanced scheduling
    Dim wo As Object
    For Each wo In workOrders
        Dim woSchedule As Collection
        Set woSchedule = ScheduleWorkOrder(wo, workflowSteps, startDate, workingHoursPerDay, useCalendarDays)
        
        ' Add scheduled steps to master schedule
        Dim step As Object
        For Each step In woSchedule
            schedule.Add step
        Next step
    Next wo
    
    ' Perform resource leveling if overallocated
    LevelResourcesInSchedule schedule, workingHoursPerDay
    
    ' Return the optimized schedule
    Set GenerateOptimizedSchedule = schedule
End Function

' Schedule a single work order with complex workflow
Private Function ScheduleWorkOrder(wo As Object, workflowSteps As Collection, _
                                  startDate As Date, workingHoursPerDay As Double, _
                                  useCalendarDays As Boolean) As Collection
    ' Implementation of topological sort-based scheduling algorithm
    ' This handles divergent and convergent workflows effectively
    
    Dim scheduledSteps As New Collection
    Dim scheduledStepIds As Object
    Set scheduledStepIds = CreateObject("Scripting.Dictionary")
    
    Dim woStartDate As Date
    woStartDate = IIf(IsDate(wo("StartDate")), wo("StartDate"), startDate)
    
    ' Create dependency graph
    Dim dependencyGraph As Object
    Set dependencyGraph = BuildDependencyGraph(workflowSteps)
    
    ' Create topological order
    Dim topologicalOrder As Collection
    Set topologicalOrder = CreateTopologicalOrder(dependencyGraph)
    
    ' Schedule steps in topological order
    Dim stepId As Variant
    For Each stepId In topologicalOrder
        ' Find step in workflow
        Dim step As Object
        Set step = FindStepById(workflowSteps, CStr(stepId))
        
        If Not step Is Nothing Then
            ' Create scheduled step
            Dim scheduledStep As Object
            Set scheduledStep = CreateObject("Scripting.Dictionary")
            
            ' Copy basic info
            scheduledStep.Add "WorkOrder", wo("WorkOrder")
            scheduledStep.Add "Product", wo("Product")
            scheduledStep.Add "StepID", step("StepID")
            scheduledStep.Add "StepName", step("StepName")
            scheduledStep.Add "Department", step("Department")
            scheduledStep.Add "ResourceRequired", step("ResourceRequired")
            scheduledStep.Add "Duration", CDbl(step("Duration"))
            scheduledStep.Add "SetupTime", CDbl(step("SetupTime"))
            
            ' Calculate start date based on prerequisites
            Dim stepStartDate As Date
            stepStartDate = woStartDate
            
            If Trim(step("Prerequisites")) <> "" Then
                Dim prereqs As Variant
                prereqs = Split(step("Prerequisites"), ",")
                
                Dim i As Long
                For i = 0 To UBound(prereqs)
                    Dim prereq As String
                    prereq = Trim(prereqs(i))
                    
                    ' Find latest end date from prerequisites
                    If scheduledStepIds.Exists(prereq) Then
                        For Each scheduledStep In scheduledSteps
                            If scheduledStep("StepID") = prereq And scheduledStep("WorkOrder") = wo("WorkOrder") Then
                                If scheduledStep("EndDate") > stepStartDate Then
                                    stepStartDate = scheduledStep("EndDate")
                                End If
                                Exit For
                            End If
                        Next
                    End If
                Next i
            End If
            
            ' Calculate end date
            Dim stepEndDate As Date
            stepEndDate = CalculateEndDate(stepStartDate, CDbl(step("Duration")), CDbl(step("SetupTime")), _
                                          workingHoursPerDay, useCalendarDays)
            
            ' Add dates to scheduled step
            scheduledStep.Add "StartDate", stepStartDate
            scheduledStep.Add "EndDate", stepEndDate
            scheduledStep.Add "Status", "Scheduled"
            
            ' Add to collection
            scheduledSteps.Add scheduledStep
            scheduledStepIds.Add step("StepID"), step("StepID")
        End If
    Next stepId
    
    ' Return the work order schedule
    Set ScheduleWorkOrder = scheduledSteps
End Function

' Build a dependency graph from workflow steps
Private Function BuildDependencyGraph(workflowSteps As Collection) As Object
    Dim graph As Object
    Set graph = CreateObject("Scripting.Dictionary")
    
    ' Initialize graph with all steps
    Dim step As Object
    For Each step In workflowSteps
        If Not graph.Exists(step("StepID")) Then
            Dim adjacencyList As New Collection
            graph.Add step("StepID"), adjacencyList
        End If
    Next step
    
    ' Add dependencies
    For Each step In workflowSteps
        If Trim(step("Prerequisites")) <> "" Then
            Dim prereqs As Variant
            prereqs = Split(step("Prerequisites"), ",")
            
            Dim i As Long
            For i = 0 To UBound(prereqs)
                Dim prereq As String
                prereq = Trim(prereqs(i))
                
                ' Add reverse edge (prerequisite -> step)
                If graph.Exists(prereq) Then
                    Dim adjacencyList As Collection
                    Set adjacencyList = graph(prereq)
                    adjacencyList.Add step("StepID")
                End If
            Next i
        End If
    Next step
    
    Set BuildDependencyGraph = graph
End Function

' Create a topological ordering of steps
Private Function CreateTopologicalOrder(graph As Object) As Collection
    Dim result As New Collection
    Dim visited As Object
    Dim temporaryMark As Object
    
    Set visited = CreateObject("Scripting.Dictionary")
    Set temporaryMark = CreateObject("Scripting.Dictionary")
    
    ' Visit all nodes
    Dim node As Variant
    For Each node In graph.Keys
        If Not visited.Exists(node) Then
            TopologicalVisit node, graph, visited, temporaryMark, result
        End If
    Next node
    
    ' Reverse the collection to get correct order
    Dim reversedResult As New Collection
    For i = result.Count To 1 Step -1
        reversedResult.Add result(i)
    Next i
    
    Set CreateTopologicalOrder = reversedResult
End Function

' Recursive function for topological sort
Private Sub TopologicalVisit(node As Variant, graph As Object, visited As Object, _
                            temporaryMark As Object, result As Collection)
    ' Check for cycle
    If temporaryMark.Exists(node) Then
        ' Circular dependency detected
        Exit Sub
    End If
    
    ' Skip if already visited
    If visited.Exists(node) Then
        Exit Sub
    End If
    
    ' Mark temporarily
    temporaryMark.Add node, True
    
    ' Visit all children
    Dim child As Variant
    For Each child In graph(node)
        TopologicalVisit child, graph, visited, temporaryMark, result
    Next child
    
    ' Mark as visited
    visited.Add node, True
    temporaryMark.Remove node
    
    ' Add to result
    result.Add node
End Sub

' Find step by ID
Private Function FindStepById(workflowSteps As Collection, stepId As String) As Object
    Dim step As Object
    
    For Each step In workflowSteps
        If step("StepID") = stepId Then
            Set FindStepById = step
            Exit Function
        End If
    Next step
    
    Set FindStepById = Nothing
End Function

' Calculate end date based on start date and duration
Private Function CalculateEndDate(startDate As Date, duration As Double, setupTime As Double, _
                                workingHoursPerDay As Double, useCalendarDays As Boolean) As Date
    Dim totalDays As Double
    Dim endDate As Date
    
    ' Total hours needed (duration + setup)
    Dim totalHours As Double
    totalHours = duration + setupTime
    
    ' Calculate days needed
    totalDays = totalHours / workingHoursPerDay
    
    If useCalendarDays Then
        ' Simple calendar days calculation
        endDate = startDate + Int(totalDays)
        
        ' Add partial day if needed
        If totalDays - Int(totalDays) > 0 Then
            endDate = endDate + 1
        End If
    Else
        ' Working days calculation (excluding weekends)
        Dim daysToAdd As Integer
        daysToAdd = Int(totalDays)
        
        endDate = startDate
        
        ' Add full days
        For i = 1 To daysToAdd
            endDate = endDate + 1
            
            ' Skip weekends
            Do While Weekday(endDate) = vbSaturday Or Weekday(endDate) = vbSunday
                endDate = endDate + 1
            Loop
        Next i
        
        ' Add partial day if needed
        If totalDays - Int(totalDays) > 0 Then
            endDate = endDate + 1
            
            ' Skip weekends
            Do While Weekday(endDate) = vbSaturday Or Weekday(endDate) = vbSunday
                endDate = endDate + 1
            Loop
        End If
    End If
    
    CalculateEndDate = endDate
End Function

' Level resources across the schedule to avoid overallocation
Private Sub LevelResourcesInSchedule(schedule As Collection, workingHoursPerDay As Double)
    ' Get all unique resources
    Dim resources As Object
    Set resources = CreateObject("Scripting.Dictionary")
    
    Dim step As Object
    For Each step In schedule
        If Not resources.Exists(step("ResourceRequired")) Then
            resources.Add step("ResourceRequired"), New Collection
        End If
        
        ' Add step to resource collection
        Dim resourceSteps As Collection
        Set resourceSteps = resources(step("ResourceRequired"))
        resourceSteps.Add step
    Next step
    
    ' Level each resource
    Dim resource As Variant
    For Each resource In resources.Keys
        LevelResourceSteps resources(resource), workingHoursPerDay
    Next resource
End Sub

' Level steps for a specific resource
Private Sub LevelResourceSteps(steps As Collection, workingHoursPerDay As Double)
    ' Sort steps by priority and start date
    SortStepsByPriorityAndDate steps
    
    ' Check for overlaps and adjust
    Dim i As Long, j As Long
    
    For i = 1 To steps.Count - 1
        Dim currentStep As Object
        Set currentStep = steps(i)
        
        For j = i + 1 To steps.Count
            Dim nextStep As Object
            Set nextStep = steps(j)
            
            ' Check if steps overlap
            If DatesOverlap(currentStep("StartDate"), currentStep("EndDate"), _
                           nextStep("StartDate"), nextStep("EndDate")) Then
                
                ' Move the next step to start after the current step
                nextStep("StartDate") = currentStep("EndDate")
                nextStep("EndDate") = CalculateEndDate(nextStep("StartDate"), _
                                                     nextStep("Duration"), _
                                                     nextStep("SetupTime"), _
                                                     workingHoursPerDay, True)
            End If
        Next j
    Next i
End Sub

' Sort steps by priority and start date
Private Sub SortStepsByPriorityAndDate(steps As Collection)
    ' Simple bubble sort
    Dim i As Long, j As Long
    Dim temp As Object
    
    For i = 1 To steps.Count - 1
        For j = i + 1 To steps.Count
            ' Compare steps based on priority and date
            If CompareSteps(steps(i), steps(j)) > 0 Then
                ' Swap steps
                Set temp = steps(i)
                Set steps(i) = steps(j)
                Set steps(j) = temp
            End If
        Next j
    Next i
End Sub

' Compare steps for sorting
Private Function CompareSteps(step1 As Object, step2 As Object) As Integer
    ' Priority based on work order priority (High > Medium > Low)
    Dim priority1 As Integer, priority2 As Integer
    
    priority1 = GetPriorityValue(GetWorkOrderPriority(step1("WorkOrder")))
    priority2 = GetPriorityValue(GetWorkOrderPriority(step2("WorkOrder")))
    
    If priority1 <> priority2 Then
        ' Higher priority comes first (lower number)
        CompareSteps = priority2 - priority1
    Else
        ' Same priority, sort by start date
        If step1("StartDate") < step2("StartDate") Then
            CompareSteps = -1
        ElseIf step1("StartDate") > step2("StartDate") Then
            CompareSteps = 1
        Else
            CompareSteps = 0
        End If
    End If
End Function

' Get work order priority from ImportedData sheet
Private Function GetWorkOrderPriority(workOrderId As String) As String
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    
    ' Default priority
    GetWorkOrderPriority = "Medium"
    
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("ImportedData")
    If Err.Number <> 0 Then Exit Function
    On Error GoTo 0
    
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    For i = 2 To lastRow
        If ws.Cells(i, 1).Value = workOrderId Then
            GetWorkOrderPriority = ws.Cells(i, 6).Value
            Exit Function
        End If
    Next i
End Function

' Convert priority string to numeric value
Private Function GetPriorityValue(priority As String) As Integer
    Select Case UCase(Trim(priority))
        Case "HIGH"
            GetPriorityValue = 1
        Case "MEDIUM"
            GetPriorityValue = 2
        Case "LOW"
            GetPriorityValue = 3
        Case Else
            GetPriorityValue = 2 ' Default to medium
    End Select
End Function

' Check if two date ranges overlap
Private Function DatesOverlap(start1 As Date, end1 As Date, start2 As Date, end2 As Date) As Boolean
    DatesOverlap = (start1 <= end2) And (end1 >= start2)
End Function

' Find the critical path in a schedule
Public Function FindCriticalPath(schedule As Collection) As Collection
    Dim criticalPath As New Collection
    Dim workOrderGroups As Object
    
    Set workOrderGroups = CreateObject("Scripting.Dictionary")
    
    ' Group steps by work order
    Dim step As Object
    For Each step In schedule
        Dim workOrderId As String
        workOrderId = step("WorkOrder")
        
        If Not workOrderGroups.Exists(workOrderId) Then
            workOrderGroups.Add workOrderId, New Collection
        End If
        
        workOrderGroups(workOrderId).Add step
    Next step
    
    ' Find critical path for each work order
    Dim workOrderId As Variant
    For Each workOrderId In workOrderGroups.Keys
        Dim workOrderSteps As Collection
        Set workOrderSteps = workOrderGroups(workOrderId)
        
        ' Find earliest and latest dates
        Dim earliestStart As Date
        Dim latestFinish As Date
        
        earliestStart = DateValue("2099-12-31")
        latestFinish = DateValue("1900-01-01")
        
        For Each step In workOrderSteps
            If step("StartDate") < earliestStart Then
                earliestStart = step("StartDate")
            End If
            
            If step("EndDate") > latestFinish Then
                latestFinish = step("EndDate")
            End If
        Next step
        
        ' Calculate the longest path
        Dim longestPathSteps As Collection
        Set longestPathSteps = CalculateLongestPath(workOrderSteps, earliestStart, latestFinish)
        
        ' Add to critical path
        For Each step In longestPathSteps
            criticalPath.Add step
        Next step
    Next workOrderId
    
    Set FindCriticalPath = criticalPath
End Function

' Calculate the longest path through a set of steps
Private Function CalculateLongestPath(steps As Collection, startDate As Date, endDate As Date) As Collection
    ' Build a directed acyclic graph
    Dim graph As Object
    Set graph = CreateObject("Scripting.Dictionary")
    
    ' Add start and end nodes
    graph.Add "START", New Collection
    graph.Add "END", New Collection
    
    ' Add all steps as nodes
    Dim step As Object
    For Each step In steps
        graph.Add step("StepID"), New Collection
    Next step
    
    ' Add edges based on prerequisites
    For Each step In steps
        If step("StartDate") = startDate Then
            ' Connect start node to steps that start at the earliest date
            Dim startEdges As Collection
            Set startEdges = graph("START")
            startEdges.Add step("StepID")
        End If
        
        If step("EndDate") = endDate Then
            ' Connect steps that end at the latest date to end node
            Dim stepEdges As Collection
            Set stepEdges = graph(step("StepID"))
            stepEdges.Add "END"
        End If
        
        ' Connect steps based on prerequisites
        For Each otherStep In steps
            If otherStep("StepID") <> step("StepID") Then
                ' If this step is a prerequisite for other step
                If IsPrerequisite(step("StepID"), otherStep) Then
                    Set stepEdges = graph(step("StepID"))
                    stepEdges.Add otherStep("StepID")
                End If
            End If
        Next otherStep
    Next step
    
    ' Calculate longest path using dynamic programming
    Dim distances As Object
    Dim predecessors As Object
    
    Set distances = CreateObject("Scripting.Dictionary")
    Set predecessors = CreateObject("Scripting.Dictionary")
    
    ' Initialize distances
    Dim node As Variant
    For Each node In graph.Keys
        distances.Add node, -1 ' -1 represents negative infinity
    Next node
    
    distances("START") = 0
    
    ' Topological sort
    Dim topologicalOrder As Collection
    Set topologicalOrder = CreateTopologicalOrder(graph)
    
    ' Calculate longest path
    For Each node In topologicalOrder
        If distances(node) <> -1 Then
            For Each adjacent In graph(node)
                Dim weight As Long
                weight = GetEdgeWeight(node, adjacent, steps)
                
                If distances(adjacent) < distances(node) + weight Then
                    distances(adjacent) = distances(node) + weight
                    If Not predecessors.Exists(adjacent) Then
                        predecessors.Add adjacent, node
                    Else
                        predecessors(adjacent) = node
                    End If
                End If
            Next adjacent
        End If
    Next node
    
    ' Reconstruct path
    Dim path As New Collection
    Dim current As String
    current = "END"
    
    Do While current <> "START"
        If current <> "END" Then
            ' Find the step with this ID
            For Each step In steps
                If step("StepID") = current Then
                    path.Add step
                    Exit For
                End If
            Next step
        End If
        
        ' Move to predecessor
        If predecessors.Exists(current) Then
            current = predecessors(current)
        Else
            Exit Do
        End If
    Loop
    
    ' Reverse path
    Dim reversedPath As New Collection
    For i = path.Count To 1 Step -1
        reversedPath.Add path(i)
    Next i
    
    Set CalculateLongestPath = reversedPath
End Function

' Check if step1 is a prerequisite for step2
Private Function IsPrerequisite(step1Id As String, step2 As Object) As Boolean
    ' Default value
    IsPrerequisite = False
    
    ' Check prerequisites
    If Trim(step2("Prerequisites")) <> "" Then
        Dim prereqs As Variant
        prereqs = Split(step2("Prerequisites"), ",")
        
        Dim i As Long
        For i = 0 To UBound(prereqs)
            If Trim(prereqs(i)) = step1Id Then
                IsPrerequisite = True
                Exit Function
            End If
        Next i
    End If
End Function

' Get weight of an edge (duration of the step)
Private Function GetEdgeWeight(fromNode As String, toNode As String, steps As Collection) As Long
    ' Default weight
    GetEdgeWeight = 1
    
    ' Special cases
    If fromNode = "START" Or toNode = "END" Then
        GetEdgeWeight = 0
        Exit Function
    End If
    
    ' Find the step
    Dim step As Object
    For Each step In steps
        If step("StepID") = fromNode Then
            ' Use duration as weight
            GetEdgeWeight = Int(step("Duration"))
            Exit Function
        End If
    Next step
End Function

' Calculate resource utilization over time
Public Function CalculateResourceUtilization(schedule As Collection) As Object
    Dim utilization As Object
    Set utilization = CreateObject("Scripting.Dictionary")
    
    ' Find date range
    Dim startDate As Date
    Dim endDate As Date
    startDate = DateValue("2099-12-31")
    endDate = DateValue("1900-01-01")
    
    Dim step As Object
    For Each step In schedule
        If step("StartDate") < startDate Then
            startDate = step("StartDate")
        End If
        
        If step("EndDate") > endDate Then
            endDate = step("EndDate")
        End If
    Next step
    
    ' Initialize utilization for each day and resource
    Dim currentDate As Date
    currentDate = startDate
    
    Do While currentDate <= endDate
        Dim dateKey As String
        dateKey = Format(currentDate, "yyyy-mm-dd")
        
        utilization.Add dateKey, CreateObject("Scripting.Dictionary")
        currentDate = currentDate + 1
    Loop
    
    ' Calculate utilization
    For Each step In schedule
        currentDate = step("StartDate")
        
        Do While currentDate <= step("EndDate")
            dateKey = Format(currentDate, "yyyy-mm-dd")
            
            Dim resourceKey As String
            resourceKey = step("ResourceRequired")
            
            Dim dateUtilization As Object
            Set dateUtilization = utilization(dateKey)
            
            If Not dateUtilization.Exists(resourceKey) Then
                dateUtilization.Add resourceKey, 0
            End If
            
            ' Add utilization (1 for each day)
            dateUtilization(resourceKey) = dateUtilization(resourceKey) + 1
            
            currentDate = currentDate + 1
        Loop
    Next step
    
    Set CalculateResourceUtilization = utilization
End Function

' Check if a resource is overallocated on a given day
Public Function IsResourceOverallocated(resourceUtilization As Object, maxResourceUtilization As Long) As Boolean
    Dim dateKey As Variant
    Dim resourceKey As Variant
    
    IsResourceOverallocated = False
    
    For Each dateKey In resourceUtilization.Keys
        Dim dateUtilization As Object
        Set dateUtilization = resourceUtilization(dateKey)
        
        For Each resourceKey In dateUtilization.Keys
            If dateUtilization(resourceKey) > maxResourceUtilization Then
                IsResourceOverallocated = True
                Exit Function
            End If
        Next resourceKey
    Next dateKey
End Function