Work allocation via VBA

[Abhishekghorpade]

Hi,

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

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
        Else
            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
       
        TargetWb.Activate
    
        ActiveWorkbook.Worksheets("MOWorkAllocation").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("MOWorkAllocation").Sort.SortFields.Add2 Key:=Range _
        ("B2:B23"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
        With ActiveWorkbook.Worksheets("MOWorkAllocation").Sort
            .SetRange Range("A1:F23")
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
       
        ' Allocate based on the current Queue
        TargetWb.Range("E1").Value = "Processor Que"
        TargetWb.Range("E2").Formula = "=INDEX(MOCurQProcessor,MATCH(A2,MOCurQTaskId,0))"
       
        TargetWb.Range("E2").Select
        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)"
       
        TargetWb.Range("F2").Select
        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)"
       
        TargetWb.Range("G2").Select
        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
               
        Columns("E").Delete
      
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
       Next
       '*********************
       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
                    Else
                        Set StartSearch = [TrainingMatrix].Rows(Match1 + 1).Find("TR", nextcel, , xlWhole, xlByRows, xlPrevious)
                    End If
               Else
                    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)
           
        Loop
             
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
               Else
                  IsPresent = 0
               End If
End Function