如何使用VBA代碼計算作業的開始時間和結束時間？

我正在嘗試在 VBA 代碼中重新創建以下計算，并且我希望將其輸出到作業表，假設列標題“處理時間”從 B4 開始：

我將如何使用 VBA 代碼在新作業表上進行這些計算？為了添加一些背景關系，我有一大堆代碼來解決調度問題 - 即，將作業分配給機械師，它本質上是一個裝箱問題，即一次可以給任何一個機械師多少作業，假設有是 8 小時的一天。您在上面看到的是每個作業的處理時間片段。到目前為止，我沒有該工具這部分的代碼，因為我不清楚從哪里開始，尤其是讓它變得動態

這個工具的要求是??一切都在 VBA 中完成，這就是為什么我不只是使用電子表格函式，這當然會簡單得多！

我的問題的第二部分與能夠顯示無法安排的作業有關，既可以作為作業表“計劃”列 F 上的串列，也可以在用戶運行計劃時向用戶顯示一個訊息框。有問題的代碼部分在“實作偽代碼”部分，我有一個被注釋掉的 else 陳述句。請看我下面的代碼：

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

當我取消注釋掉我的“else”陳述句時，結果是不正確的，訊息框只向我顯示所有實際安排的作業，但作為單獨的訊息框而不是同一訊息框中的串列。

我想要的結果是能夠顯示未計劃作業的串列以及一個訊息框。我已經被困在這個問題上好幾天了，我確信有一些我沒有做的超級簡單的事情，但任何幫助都將不勝感激:)

謝謝！！

uj5u.com熱心網友回復：

我已添加mechanic到jobData以識別未分配的作業。

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

標籤：擅长 vba

上一篇：如何調整事件SelectionChange代碼以在事件計算中作業？

下一篇：如果使用vba的Excel電子表格中的單元格為空白，則將一列中文本的最后3個字符復制到另一列