I am trying to recreate this below calculation in VBA code and I would like it to be output to a worksheet imagine that the column title 'processing time' starts from B4:

How would I go about getting these calculations on a new sheet using VBA code? To add a bit of context, I have a whole bunch of code that solves a scheduling problem - i.e., distributing jobs to mechanics it is essentially a bin packing problem of how many jobs can be given to any one mechanic at a time, assuming there is an 8 hour day. What you see above is a snippet of processing times for each job. So far I have no code for this part of the tool as I was unclear on where to start especially to make it dynamic

The requirement of this tool is that everything is done in VBA which is why I am not just using spreadsheet functions, which of course would be far simpler!

The second part of my question relates to being able to show the jobs that weren't able to be scheduled, both as a list on sheet "Schedule" column F and also has a message box to the user when they run the schedule. The part of the code in question is in the section 'implement pseudocode' where I have an else statement that is commented out. Please see me code below:

Option Explicit

Type jobData
    jobID As Long
    processingTime As Double
End Type

Type mechanicData
    availableHours As Double                        'This takes into consideration the amount of workable hours per day
    remainingAvailableHours As Double               'This decreases as more jobs are added on to each mechanics workload
    jobsToMechanic() As Long                        'Record the jobs to each mechanic
    makeSpan As Long                                'How many hours the each mechanic has used so far
End Type

Sub ScheduleMechanics()

    'Define problem size variables
    
    Dim numJobs As Long
    Dim numMechanics As Long
    
    'Read data
    
    ThisWorkbook.Worksheets("Data").Activate
    
    numJobs = Cells(1, 2).Value                     'How many jobs are in sequence
    numMechanics = Cells(2, 2).Value                'How many mechanics are available
    
    'Sort processing time data from worksheet
    
    Range(Cells(4, 1).Address & ":" & Cells(4   numJobs, 2).Address).Select
    ActiveWorkbook.Worksheets("Data").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Data").Sort.SortFields.Add2 Key:=Range(Cells(5, 2).Address & ":" & Cells(4   numJobs, 2).Address) _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Data").Sort
        .SetRange Range(Cells(4, 1).Address & ":" & Cells(4   numJobs, 2).Address)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    'Error handling for Item ID and size
    
    Range(Cells(5, 1).Address & ":" & Cells(5   numJobs   1, 2).Address).Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateWholeNumber, AlertStyle:=xlValidAlertStop, _
        Operator:=xlGreaterEqual, Formula1:="0"
        .IgnoreBlank = False
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = "Error"
        .InputMessage = ""
        .ErrorMessage = "Please enter numerical values only."
        .ShowInput = True
        .ShowError = True
    End With
    
    Dim jobList() As jobData
    ReDim jobList(1 To numJobs)

    
    Dim i As Long                                                   'Loop counter 1
    
    For i = 1 To numJobs
        jobList(i).jobID = Cells(4   i, 1).Value                    'Determining processing time
        jobList(i).processingTime = Cells(4   i, 2).Value
    Next i
    
    Dim Mechanic() As mechanicData
    ReDim Mechanic(1 To numMechanics)
    
    For i = 1 To numMechanics
        Mechanic(i).availableHours = Cells(3, 2).Value
    Next i
    
    'Initialise the solution where all mechanics have an empty schedule with a makespan of 0
    
    For i = 1 To numMechanics
        Mechanic(i).remainingAvailableHours = Mechanic(i).availableHours
        Mechanic(i).makeSpan = 0
        ReDim Mechanic(i).jobsToMechanic(1 To numJobs)
    Next i
    
    'Implement pseudocode
    
    Dim j As Long                                                    'Loop counter 2
    Dim minMakespan As Long
    Dim mechanicSelected As Long
    
    For i = 1 To numJobs

        minMakespan = 9
        mechanicSelected = 0

            For j = 1 To numMechanics

                If Mechanic(j).makeSpan < minMakespan And _
                    Mechanic(j).makeSpan   jobList(i).processingTime <= Mechanic(j).availableHours Then
                    mechanicSelected = Mechanic(j).remainingAvailableHours
                    minMakespan = Mechanic(j).makeSpan
                End If


                'if job i fits in mehcanic j's schedule then
                If jobList(i).processingTime <= Mechanic(j).remainingAvailableHours Or _
                mechanicSelected > 0 Then

                    'place job i in mechanic j's schedule and update the makespan of mechanicSelected
                    Mechanic(j).makeSpan = Mechanic(j).makeSpan   1
                    Mechanic(j).jobsToMechanic(Mechanic(j).makeSpan) = jobList(i).jobID
                    Mechanic(j).remainingAvailableHours = Mechanic(j).remainingAvailableHours - jobList(i).processingTime
                'Else
                    'Report job i as unfeasible to scheduled on day
                    'MsgBox "Job ID " & jobList(i).jobID & " is unfeasible to be scheduled on this day", vbInformation, "Information"

                    Exit For

                End If

            Next j

        Next i
        
    'Lets the user know the algorithm is completed
    MsgBox "Algorithm Completed.", vbInformation, "Success!"

    
    'Write the result
    
    ThisWorkbook.Worksheets("Schedule").Activate
    
    'Erase before writing
    
    Columns("A:J").ClearContents
    
    Dim rowIndex As Long
    Dim startTime As Integer
    Dim endtime As Integer
    
    rowIndex = 1
    startTime = 0

    
    For i = 1 To numJobs
        jobList(i).processingTime = Cells(4   i, 2).Value
    Next i
    
    'Naming column names
    
    Cells(1, 1).Value = "Mechanic"
    Cells(1, 2).Value = "Job ID"
    Cells(1, 3).Value = "Job Processing Time"
    Cells(1, 4).Value = "Start Time (Hrs)"
    Cells(1, 5).Value = "End Time (Hrs)"
    Cells(1, 6).Value = "Unscheduled Jobs"
    
    Rows("1").Select
    Selection.Font.Bold = True
    
    rowIndex = rowIndex   1
    
    For j = 1 To numMechanics
        Cells(rowIndex, 1).Value = "Mechanic " & j
        
        For i = 1 To Mechanic(j).makeSpan
            Cells(rowIndex, 2).Value = "Job " & Mechanic(j).jobsToMechanic(i)
            Cells(rowIndex, 3).Value = Application.WorksheetFunction.vLookup _
            (Mechanic(j).jobsToMechanic(i), ThisWorkbook.Worksheets("Data").Columns("A:B"), 2, False) & "hrs"
            If Mechanic(j).jobsToMechanic(i) = 1 Then
                Cells(rowIndex, 4).Value = startTime
                Else
                Cells(rowIndex, 4).Value = startTime   jobList(i).processingTime
            End If
            'Cells(rowIndex, 5).Value =
            rowIndex = rowIndex   1
        Next i
        rowIndex = rowIndex   1
    Next j
    
    'AutoFit All Columns on Worksheet
    ThisWorkbook.Worksheets("Schedule").Cells.EntireColumn.AutoFit
    
    'Housekeeping
    
    Erase jobList
    Erase Mechanic
     
End Sub

When I uncomment out my 'else' statement the results are then incorrect and the message box just shows me all the jobs that are actually scheduled but as individual message boxes rather than a list within the same message box.

My desired result is to be able to show the list of unscheduled jobs and also a message box. I've been stuck on this for days, I am sure there is something super simple that I have failed to do, but any help would be so appreciated :)

Thank you!!

CodePudding user response：

I have added mechanic to jobData to identify unallocated jobs.

Option Explicit

Type jobData
    jobID As Long
    processingTime As Double
    mechanic As Long
End Type

Type mechanicData
    availableHours As Double           'This takes into consideration the amount of workable hours per day
    remainingAvailableHours As Double  'This decreases as more jobs are added on to each mechanics workload
    jobsToMechanic() As Long           'Record the jobs to each mechanic
    makeSpan As Long                   'How many jobs a mechanic has so far
End Type

Sub ScheduleMechanics()

    'Define problem size variables
    Dim numJobs As Long
    Dim numMechanics As Long
    
    'Read data
    With ThisWorkbook.Worksheets("Data")
    
        numJobs = .Cells(1, 2).Value      'How many jobs are in sequence
        numMechanics = .Cells(2, 2).Value  'How many mechanics are available
        
        'Sort processing time data from worksheet
        .Sort.SortFields.Clear
        .Sort.SetRange .Range("A4:B" & 4   numJobs)
        .Sort.SortFields.Add Key:=.Range("B4"), SortOn:=xlSortOnValues, _
           Order:=xlDescending, DataOption:=xlSortNormal
        With .Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        'Error handling for Item ID and size
        With .Range("A5:B" & numJobs - 1).Validation
            .Delete
            .Add Type:=xlValidateWholeNumber, AlertStyle:=xlValidAlertStop, _
            Operator:=xlGreaterEqual, Formula1:="0"
            .IgnoreBlank = False
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = "Error"
            .InputMessage = ""
            .ErrorMessage = "Please enter numerical values only."
            .ShowInput = True
            .ShowError = True
        End With
        
        Dim jobList() As jobData
        ReDim jobList(1 To numJobs)
        Dim i As Long
        For i = 1 To numJobs
            jobList(i).jobID = .Cells(4   i, 1).Value
            jobList(i).processingTime = .Cells(4   i, 2).Value
            jobList(i).mechanic = 0
        Next
    
        Dim mechanic() As mechanicData
        ReDim mechanic(1 To numMechanics)
        'Initialise the solution where all mechanics have an empty schedule
        'with a makespan of 0
        For i = 1 To numMechanics
            mechanic(i).availableHours = .Cells(3, 2).Value
            mechanic(i).remainingAvailableHours = mechanic(i).availableHours
            mechanic(i).makeSpan = 0
            ReDim mechanic(i).jobsToMechanic(1 To numJobs)
        Next

    End With
    
    'Implement pseudocode
    Dim j As Long, msg As String                                                    'Loop counter 2
    Dim minMakespan As Long
    Dim mechanicSelected As Long
        
    For i = 1 To numJobs
        mechanicSelected = 0
        For j = 1 To numMechanics

            'if job i fits in mehcanic j's schedule then
            If jobList(i).processingTime <= mechanic(j).remainingAvailableHours Then
                mechanicSelected = j
                jobList(i).mechanic = i
                'place job i in mechanic j's schedule and update the makespan of mechanicSelected
                mechanic(j).makeSpan = mechanic(j).makeSpan   1
                mechanic(j).jobsToMechanic(mechanic(j).makeSpan) = i
                mechanic(j).remainingAvailableHours = mechanic(j).remainingAvailableHours - jobList(i).processingTime
                Exit For
            End If
            
        Next j
        
        If mechanicSelected = 0 Then
            msg = msg & vbLf & jobList(i).jobID _
            & " (" & jobList(i).processingTime & " hrs}"
        End If
    Next i
    
    'Lets the user know the algorithm is completed
    If Len(msg) > 0 Then
        MsgBox "Not able to scheduled these jobs : " & msg, _
        vbExclamation, "Failure"
    Else
        MsgBox "Algorithm Completed.", vbInformation, "Success!"
    End If
    
    'Write the result
    Dim rowIndex As Long
    Dim startTime As Integer
    Dim endTime As Integer
    Dim job As jobData
    
    With ThisWorkbook.Worksheets("Schedule")
    
        'Erase before writing
        .Columns("A:J").ClearContents
        
        'Naming column names
        .Cells(1, 1).Value = "Mechanic"
        .Cells(1, 2).Value = "Job ID"
        .Cells(1, 3).Value = "Job Processing Time"
        .Cells(1, 4).Value = "Start Time (Hrs)"
        .Cells(1, 5).Value = "End Time (Hrs)"
        .Cells(1, 6).Value = "Unscheduled Jobs"
        .Rows("1").Font.Bold = True
        
        rowIndex = 2
        
        For j = 1 To numMechanics
            .Cells(rowIndex, 1).Value = "Mechanic " & j
            
            For i = 1 To mechanic(j).makeSpan
                job = jobList(mechanic(j).jobsToMechanic(i))
                .Cells(rowIndex, 2).Value = "Job " & job.jobID
                .Cells(rowIndex, 3).Value = job.processingTime & " hrs"
                If i = 1 Then
                    startTime = 0
                End If
                endTime = startTime   job.processingTime
                .Cells(rowIndex, 4).Value = startTime
                .Cells(rowIndex, 5).Value = endTime
                rowIndex = rowIndex   1
                startTime = endTime ' next job
            Next i
            rowIndex = rowIndex   1
        Next j
        
        ' unscheduled jobs
        rowIndex = 1
        For i = 1 To numJobs
            If jobList(i).mechanic = 0 Then
                rowIndex = rowIndex   1
                .Cells(rowIndex, 6) = jobList(i).jobID _
                & " (" & jobList(i).processingTime & " hrs)"
            End If
        Next
        'AutoFit All Columns on Worksheet
        .Columns("A:J").EntireColumn.AutoFit
        .Activate
        .Range("A1").Select
    End With
    MsgBox "Done"
    'Housekeeping
    Erase jobList
    Erase mechanic
     
End Sub