Work allocation via VBA


Board Regular
Oct 3, 2018

I am creating Macro to allocate the work to team members. I have created a VBA however there is some issue with the looping.
In the sheet 'MO.Individual Training Tracker' i have stored all the task types, employee name and there training status. Whenever VBA is allocating the tasks it is starting from the first person resulting more tasks are assigning to one person.
What i am expecting is VBA should consider last assigned person and start looping from the next employee.
Please help me on this. your time efforts will be greatly appreciated

Below is the code i am currently using

VBA Code:
Public Sub AllocateWork()
       Dim TargetWb, SourceWb As Worksheet
       Dim Array_of_Ranges(), ToBeAssignedRange, cel, firstcel, nextcel, PlanRng As Range
       Dim Match1, Match2, lcopylastrow, StepCol As Long
       Dim MIPlan, Assign, Number_of_cells, assignment, PlanId As String
       Dim ChkFile, FilePath As String
       Dim temprng As Range
       FilePath = ThisWorkbook.Worksheets("Path").Range("B1").Value
       ' FilePath = "C:\BackUp\DBAckup\INNOVATION\realtime_sla_role.xls.xlsx"
       If FilePath = "" Then
           MsgBox "Report file path missing in 'Path' sheet's B2 cell: Enter valid path of report"
           Exit Sub
       End If
       ChkFile = ""
       On Error Resume Next
       ChkFile = Dir(FilePath)
       On Error GoTo 0
        If ChkFile = "" Then
            MsgBox "Enter Valid path or file name in the 'Path' sheet B2 cell"
            Exit Sub
            Workbooks.Open (FilePath)
        End If
        Set SourceWb = Workbooks("realtime_sla_role.xls").Worksheets("Report")
        Set TargetWb = ThisWorkbook.Worksheets("MOWorkAllocation")
        lcopylastrow = SourceWb.Cells(SourceWb.Rows.Count, "A").End(xlUp).Row
        SourceWb.Range("A1:Y" & lcopylastrow).AutoFilter Field:=23, Criteria1:=Array("RETIREMENT Queue"), Operator:=xlFilterValues

        SourceWb.Range("A1:Y" & lcopylastrow).AutoFilter Field:=10, Criteria1:=Array("PROCESS"), Operator:=xlFilterValues
       ' Copy the required columns from the report to this workbook
        SourceWb.Range("A1:A" & lcopylastrow).Copy TargetWb.Range("A1")
        SourceWb.Range("I1:J" & lcopylastrow).Copy TargetWb.Range("B1")
        SourceWb.Range("W1:W" & lcopylastrow).Copy TargetWb.Range("D1")
        lcopylastrow = TargetWb.Cells(TargetWb.Rows.Count, "A").End(xlUp).Row
        ActiveWorkbook.Worksheets("MOWorkAllocation").Sort.SortFields.Add2 Key:=Range _
        ("B2:B23"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        With ActiveWorkbook.Worksheets("MOWorkAllocation").Sort
            .SetRange Range("A1:F23")
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
        End With
        ' Allocate based on the current Queue
        TargetWb.Range("E1").Value = "Processor Que"
        TargetWb.Range("E2").Formula = "=INDEX(MOCurQProcessor,MATCH(A2,MOCurQTaskId,0))"
        Selection.AutoFill Destination:=Range("E2:E" & lcopylastrow)
        'Code for PRocessor Flag
        TargetWb.Range("F1:F" & lcopylastrow).ClearContents
        TargetWb.Range("F1").Value = "Processor Flag"
        TargetWb.Range("F2").Formula = "=IF(ISNA(E2),0,1)"
        Selection.AutoFill Destination:=Range("F2:F" & lcopylastrow)
        'Pasted values in the column H - Processor Flag
        TargetWb.Range("F2:F" & lcopylastrow).Copy
        'PasteSpecial Values Only
        TargetWb.Range("F2").PasteSpecial Paste:=xlPasteValues
        'Code to filter N/A from Processor Que column
        TargetWb.Range("G1:G" & lcopylastrow).ClearContents
        TargetWb.Range("G1").Value = "Processor"
        TargetWb.Range("G2").Formula = "=IF(ISNA(E2),"""",E2)"
        Selection.AutoFill Destination:=Range("G2:G" & lcopylastrow)
         'Pasted values in the column G - Processor
        TargetWb.Range("G2:G" & lcopylastrow).Copy
        'PasteSpecial Values Only
        TargetWb.Range("G2").PasteSpecial Paste:=xlPasteValues
End Sub

Public Sub AssignNames()

       Dim ws As Worksheet
       Dim Array_of_Ranges() As Range
       Dim cel As Range, firstcel, nextcel, StartSearch As Range, StrCell As String
       Dim NumRowsToAssign, NumTotTasks, NumMinTasks, NumMaxTasks As Integer
       'Dictionary object for names and task counts
       Dim dict As Scripting.Dictionary
       Set dict = New Scripting.Dictionary
       dict.CompareMode = vbTextCompare
       Set ws = ThisWorkbook.Worksheets("MOWorkAllocation")
       NumRowsToAssign = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
       RowCount = 2
       i = 0
       '*********** adding names of current queue to dictionary ******
       For Rcnt = 2 To NumRowsToAssign
            Processor = Trim(ws.Cells(Rcnt, "F").Value)
            If Processor <> "" Then
                dict(Processor) = dict(Processor) + 1
            End If
       CountP = Application.WorksheetFunction.CountIf([Attendance], "P")
       'MsgBox CountP
       NumTotTasks = NumRowsToAssign
       NumMinTasks = NumRowsToAssign \ CountP       'Code for # of tasks/resources present to get min task that can be assigned to each
       'NumMinTasks = Round(NumMinTasks)
       NumMaxTasks = NumMinTasks + 1
       Do While RowCount <= NumRowsToAssign
           TaskType = ws.Cells(RowCount, "B").Value
           NextTask = ws.Cells(RowCount + 1, "B").Value
           Match1 = Application.WorksheetFunction.Match(TaskType, [TrainingTaskType], 0)
           ChkTask = StrComp(TaskType, NextTask, 1)
           Set StartSearch = [TrainingMatrix].Rows(Match1 + 1).Cells(1, 2)
           Do  ' Loop to iterate each resource
               TaskType = ws.Cells(RowCount, "B").Value
               NextTask = ws.Cells(RowCount + 1, "B").Value
               ChkTask = StrComp(TaskType, NextTask, 1)
               Set firstcel = [TrainingMatrix].Rows(Match1 + 1).Find("TR", StartSearch, , xlWhole, xlByRows, xlNext)
               If firstcel Is Nothing Then
                    ws.Cells(RowCount, "F").Value = "No trained resources to assign!!"
                    RowCount = RowCount + 1
                    Exit Do
               End If
               Set nextcel = [TrainingMatrix].Rows(Match1 + 1).Find("TR", firstcel, , xlWhole, xlByRows, xlNext)
               'StrCell = firstcel.Address
               'StrCell2 = nextcel.Address
               assignment = Trim(Application.WorksheetFunction.Index([TrainingProcessor], firstcel.Column - 2))
               FlagAttendance = IsPresent(assignment)
               If ws.Cells(RowCount, "F").Value = "" Then
                    If FlagAttendance Then
                        taskcnt = dict(assignment)
                       ' If taskcnt < NumMinTasks Then ' Or ChkTask = 0)
                            ws.Cells(RowCount, "F").Value = assignment
                            dict(assignment) = dict(assignment) + 1
                            Set StartSearch = [TrainingMatrix].Rows(Match1 + 1).Find("TR", nextcel, , xlWhole, xlByRows, xlPrevious)
                            'Set StartSearch = firstcel
                            RowCount = RowCount + 1
                       ' Else
                        '    ws.Cells(RowCount, "F").Value = assignment
                         '   dict(assignment) = dict(assignment) + 1
                          '  Set StartSearch = [TrainingMatrix].Rows(Match1 + 1).Find("TR", nextcel, , xlWhole, xlByRows, xlPrevious)
                           ' RowCount = RowCount + 1
                       ' End If
                        Set StartSearch = [TrainingMatrix].Rows(Match1 + 1).Find("TR", nextcel, , xlWhole, xlByRows, xlPrevious)
                    End If
                    Set nextcel = [TrainingMatrix].Rows(Match1 + 1).Find("TR", nextcel, , xlWhole, xlByRows, xlPrevious)
                    Set StartSearch = [TrainingMatrix].Rows(Match1 + 1).Find("TR", nextcel, , xlWhole, xlByRows, xlPrevious)
                    RowCount = RowCount + 1
               End If
            Loop While (ChkTask = 0 And RowCount <= NumRowsToAssign)
End Sub

Public Function IsPresent(assignment)
'Code to find if resource trained is present
               MatchAttendRow = Application.WorksheetFunction.Match(assignment, [AttendanceName], 0)
               If (Application.WorksheetFunction.Index([AttendanceMatrix], MatchAttendRow, 3) = "P") Then
                  IsPresent = 1
                  IsPresent = 0
               End If
End Function

Some videos you may like

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.

Watch MrExcel Video

Forum statistics

Latest member