Almost-evenly split groups among 4 1

[PRMiller2]

I have a number of phone calls that need to be made to clients in a variety of states every day. I have four staffers making those phone calls, and they will be splitting up the work-load by state, so that no two staffers make calls to the same states.

Here's what the data looks like:

State Clients
AL 11
AK 1
CA 7
CT 4
DE 13
FL 8
MN 4

Here's the kicker: the states requiring phone calls could vary by day. In other words, if the above list was today, tomorrow's list could see CA drop off and ID, MI and ND added. Additionally, the number of clients requiring phone calls in CA may change.

I need to determine the best way to make assignments to these 4 staffers on a daily basis. Using the above example, it might be fair to split up the workload as follows:

Staffer #1: AL and AK = 12 clients
Staffer #2: CA and CT = 11 clients
Staffer #3: DE = 13
Staffer #4: FL and MN = 12 clients

It's not exactly even, but close enough.

What is the best way to go about automating something like this? I suspect whatever I do will end up having to be written in VBA, but thought this would be a good place to start.

 

[addy]

Is the data for State, Clients held in a table (with this structure)? Is it updated, or deleted and created fresh every day? Can you change the structure if required?

Got a couple of ideas how to do this but need to know a little more info.

 

[Andrzejek]

Also, you said: "no two staffers make calls to the same states." Does it mean that only Staffer #2 calls CA? Or Staffer #2 could call CA today, but next day Staffer #4 calls CA?

Have fun.

---- Andy

 

[BigRed1212]

Is the data is summary form
(ca= 12)

or in detail form
client_id state
1 ca
123 ca
345 ca
876 ca
987 ca
etc
that is summarized?

 

[MajP]

This problem is a classic Assignment optimization model of operations research with a twist. Most assignment models deal with minimizing the cost of assigning tasks to a group where there is 1 tasks per person. This can be solved in a standard simplex method, but there are dedicated more efficient algorithms. The normal method uses something called the Hungarian algorithm. Your problem is more complex and I believe it is Non-Polynomial time hard (NPH). I am sure there is a dedicated algorithm to do this, but I am not smart enough to figure it out. Your objective function is non-linear because it is
Minimize the variance of the total calls per person. The other issue is that even if you could formulate this which is not that easy, you then have to reformulate it for changes in the number of staffers and assignments. You could try to enumerate all possible solutions, but that blows up real quick and it is hard to write an algorithm to do it. A common heuristic therefore is to use an improving algorithm. You start with an initial assignment and then try to improve it by swapping nodes.

To make things easier you can use the power of SQL to do a lot of work for you. To prove this algorithm is a pretty good heuristic I made the problem more challenging. I assumed there was 50 states with a random number of calls between 0-100.

StateID	RequiredCalls
AK	80
AL	2
AR	64
AZ	60
CA	96
CO	26
CT	41
DE	44
FL	4
GA	35
HI	54
IA	95
ID	51
IL	51
IN	95
KS	14
KY	51
LA	58
MA	9
MD	41
ME	40
MI	17
MN	59
MO	52
MS	5
MT	57
NC	96
ND	52
NE	63
NH	12
NJ	43
NM	90
NV	9
NY	23
OH	74
OK	6
OR	62
PA	87
RI	23
SC	0
SD	61
TN	88
TX	94
UT	22
VA	11
VT	35
WA	62
WI	56
WV	73
WY	18

first I built a table for the assignments
tblStafferStateAssignment
stafferID
stateID

This is where the assignments go.

Then I built a few queries to help

qryAssignments

SELECT tblStaffers.StafferID, tblStateRequirements.StateID, tblStateRequirements.RequiredCalls
FROM (tblStafferStateAssignment INNER JOIN tblStaffers ON tblStafferStateAssignment.StafferID = tblStaffers.StafferID) INNER JOIN tblStateRequirements ON tblStafferStateAssignment.StateID = tblStateRequirements.StateID
ORDER BY tblStaffers.StafferID, tblStateRequirements.RequiredCalls;

qryStafferTotals

SELECT qryAssignments.StafferID, Sum(qryAssignments.RequiredCalls) AS SumOfRequiredCalls
FROM qryAssignments
GROUP BY qryAssignments.StafferID;

qryGroupStats
needed to get the average number of calls per person and the standard dev of the calls per person

SELECT StDev(qryStafferTotals.SumOfRequiredCalls) AS StDevRequiredCalls, Avg(qryStafferTotals.SumOfRequiredCalls) AS AvgRequiredCalls
FROM qryStafferTotals;

So First thing to do is just load the assignment table by looping through the states and dealing them out like cards.

Public Sub InitialAssignments()
  Dim RSState As DAO.Recordset
  Dim RSStaffers As DAO.Recordset
  Dim RSAssignment As DAO.Recordset
  Dim strSql As String
  Dim StafferID As Long
  Dim StateID As String
  
  ClearAssignments
  Set RSState = CurrentDb.OpenRecordset("SELECT * FROM tblStateRequirements ORDER BY RequiredCalls")
  Set RSStaffers = CurrentDb.OpenRecordset("SELECT * FROM tblStaffers ORDER BY StafferID")

  Do While Not RSState.EOF
      If RSStaffers.EOF Then RSStaffers.MoveFirst
      StateID = RSState!StateID
      StafferID = RSStaffers!StafferID
      RSStaffers.MoveNext
      strSql = "INSERT INTO tblStafferStateAssignment (StafferID, StateID) VALUES (" & StafferID & ", '" & StateID & "')"
      CurrentDb.Execute strSql
    RSState.MoveNext
  Loop
End Sub

Public Sub ClearAssignments()
  'Clear out old assignments
  Dim strSql As String
  strSql = "Delete * from tblStafferStateAssignment"
  CurrentDb.Execute strSql
End Sub

Based on the "dealing of the cards" you would end up with these stats

StafferID	SumOfRequiredCalls
1              602
2              626
3              553
4              580

StDevRequiredCalls  AvgRequiredCalls
31.1381331061021    590.25

So know you can try to improve by swapping assignments.
Since staffer 1 has more than the average he will try to swap with someone who has less then the average and give up a large value for a small value. Also ensuring that the overall standard deviation improves. So staffer 1 will give something to staffer 3 or 4. This method is known as a 1 node replacement. If Staffer 1 is still more than the average he tries to swap again. Once he can not improve anymore it is on to staffer 2 and the process repeats.

Public Sub ImproveBySwapping()
  Dim RSTotals As DAO.Recordset
  Dim strSql As String
  Dim StafferID As Long
  Dim TotalCalls As Long
  Dim AvgCalls As Double
  Dim StatesAssigned As Long
  Dim DiffFromAvg As Double
  Dim improved As Boolean
  Set RSTotals = CurrentDb.OpenRecordset("qryStafferTotals")
  'kick start
  improved = True
  Do While improved
    improved = False
    RSTotals.MoveFirst
  Do While Not RSTotals.EOF
     StafferID = RSTotals!StafferID
     TotalCalls = RSTotals!SumOfRequiredCalls
     AvgCalls = GetAvgCalls
     StatesAssigned = DCount("StateID", "qryAssignments", "StafferID = " & StafferID)
     DiffFromAvg = AvgCalls - TotalCalls
     If DiffFromAvg > 0 Then
       'Can possibly improve by adding more
       improved = TryToSwapForMore(StafferID)
     ElseIf DiffFromAvg < 0 Then
       'Can possibly improve by reducing
        improved = TryToSwapForLess(StafferID)
     End If
     'Debug.Print StafferID & " " & TotalCalls & " " & AvgCalls & " " & StatesAssigned
     RSTotals.MoveNext
  Loop
  Loop
End Sub

Public Function TryToSwapForMore(StafferID As Long) As Boolean
  Dim PriorSDev As Double
  Dim RSMyAssignments As DAO.Recordset
  Dim RSAvailableAssignments As DAO.Recordset
  Dim GiveState As String
  Dim GiveAmount As Long
  Dim TakeState As String
  Dim TakeAmount As Long
  Dim TakeStaffer As Long
  Dim isSwapped As Boolean
  PriorSDev = GetCurrentSDev
  Set RSMyAssignments = CurrentDb.OpenRecordset("Select * from QryAssignments where StafferID = " & StafferID & " ORDER BY RequiredCalls")
  Set RSAvailableAssignments = CurrentDb.OpenRecordset("Select * from QryAssignments where StafferID <> " & StafferID & " ORDER BY RequiredCalls DESC")
  
  Do While Not RSMyAssignments.EOF
    GiveState = RSMyAssignments!StateID
    GiveAmount = RSMyAssignments!RequiredCalls
    If GetAvgCalls <= GetTotalCalls(StafferID) Then Exit Function
    Do While Not RSAvailableAssignments.EOF And Not isSwapped
      TakeState = RSAvailableAssignments!StateID
      TakeAmount = RSAvailableAssignments!RequiredCalls
      TakeStaffer = RSAvailableAssignments!StafferID
      
      If TakeAmount > GiveAmount Then
        PriorSDev = GetCurrentSDev
       ' Debug.Print "GIVE: " & GiveState & " " & GiveAmount
       ' Debug.Print "TAKE: " & TakeState & " " & TakeAmount
        SwapAssignments StafferID, TakeStaffer, GiveState, TakeState
        'Debug.Print PriorSDev & " " & GetCurrentSDev
        If PriorSDev < GetCurrentSDev Then
          'SwapBack
         ' Debug.Print "swapBack"
          SwapAssignments StafferID, TakeStaffer, TakeState, GiveState
        Else
          Debug.Print "Swapped: Give : " & GiveState & " Take: " & TakeState
          isSwapped = True
          TryToSwapForMore = True
        End If
      End If
      
      RSAvailableAssignments.MoveNext
    Loop
    RSMyAssignments.MoveNext
  Loop
End Function

Public Function TryToSwapForLess(StafferID As Long) As Boolean
  Dim PriorSDev As Double
  Dim RSMyAssignments As DAO.Recordset
  Dim RSAvailableAssignments As DAO.Recordset
  Dim GiveState As String
  Dim GiveAmount As Long
  Dim TakeState As String
  Dim TakeAmount As Long
  Dim TakeStaffer As Long
  Dim isSwapped As Boolean
  PriorSDev = GetCurrentSDev
  Set RSMyAssignments = CurrentDb.OpenRecordset("Select * from QryAssignments where StafferID = " & StafferID & " ORDER BY RequiredCalls DESC")
  Set RSAvailableAssignments = CurrentDb.OpenRecordset("Select * from QryAssignments where StafferID <> " & StafferID & " ORDER BY RequiredCalls")
  
  Do While Not RSMyAssignments.EOF
    GiveState = RSMyAssignments!StateID
    GiveAmount = RSMyAssignments!RequiredCalls
    If GetAvgCalls >= GetTotalCalls(StafferID) Then Exit Function
    Do While Not RSAvailableAssignments.EOF And Not isSwapped
      TakeState = RSAvailableAssignments!StateID
      TakeAmount = RSAvailableAssignments!RequiredCalls
      TakeStaffer = RSAvailableAssignments!StafferID
      
      If TakeAmount < GiveAmount Then
        PriorSDev = GetCurrentSDev
       ' Debug.Print "GIVE: " & GiveState & " " & GiveAmount
       ' Debug.Print "TAKE: " & TakeState & " " & TakeAmount
        SwapAssignments StafferID, TakeStaffer, GiveState, TakeState
        'Debug.Print PriorSDev & " " & GetCurrentSDev
        If PriorSDev < GetCurrentSDev Then
          'SwapBack
         ' Debug.Print "swapBack"
          SwapAssignments StafferID, TakeStaffer, TakeState, GiveState
        Else
          Debug.Print "Swapped: Give : " & GiveState & " Take: " & TakeState
          isSwapped = True
          TryToSwapForLess = True
        End If
      End If
      
      RSAvailableAssignments.MoveNext
    Loop
    RSMyAssignments.MoveNext
  Loop
End Function

Public Sub SwapAssignments(GiveStaffer As Long, TakeStaffer As Long, GiveState As String, TakeState As String)
  Dim strSql As String
  strSql = " UPDATE tblStafferStateAssignment SET tblStafferStateAssignment.StafferID = " & GiveStaffer & " WHERE tblStafferStateAssignment.StateID= '" & TakeState & "'"
 ' Debug.Print strSql
  CurrentDb.Execute strSql
  strSql = " UPDATE tblStafferStateAssignment SET tblStafferStateAssignment.StafferID = " & TakeStaffer & " WHERE tblStafferStateAssignment.StateID= '" & GiveState & "'"
  'Debug.Print strSql
  CurrentDb.Execute strSql
End Sub

And some helper functions

Public Function GetCurrentSDev() As Double
  GetCurrentSDev = DLookup("STdevRequiredCalls", "QryGroupStats")
End Function
Public Function GetAvgCalls() As Double
  GetAvgCalls = DLookup("avgRequiredCalls", "qryGroupStats")
End Function
Public Function GetTotalCalls(StafferID As Long) As Long
  GetTotalCalls = DLookup("SumOfRequiredCalls", "qryStafferTotals", "StafferID = " & StafferID)
End Function

And the results

StafferID   SumOfRequiredCalls
1           590
2           590
3           591
4           590

StDevRequiredCalls   AvgRequiredCalls
0.5                  590.25

StafferID StateID RequiredCalls
1	AL	2
1	CA	96
1	FL	4
1	HI	54
1	ID	51
1	MN	59
1	NC	96
1	ND	52
1	NH	12
1	OH	74
1	OK	6
1	UT	22
1	WA	62
2	AK	80
2	AZ	60
2	CO	26
2	GA	35
2	IA	95
2	KS	14
2	KY	51
2	NE	63
2	NJ	43
2	NV	9
2	NY	23
2	VT	35
2	WI	56
3	AR	64
3	DE	44
3	MA	9
3	ME	40
3	MI	17
3	MS	5
3	MT	57
3	NM	90
3	PA	87
3	RI	23
3	SD	61
3	TX	94
4	CT	41
4	IL	51
4	IN	95
4	LA	58
4	MD	41
4	MO	52
4	OR	62
4	SC	0
4	TN	88
4	VA	11
4	WV	73
4	WY	18

Although that is pretty darn good for a problem of that size (imagine trying to do that by hand) in truth it may perform better on a problem of that size versus the seven state problem. Although it does give the results you propose.

This model only swaps, so basically the solution has everyone with about the same amount of states. If the variance in the calls is big and the number of states is small you may want to have a model that would account for that. So one person may have only one state and someone else would have four states.

That could be written into this model. After improving by swapping, apply a similar method of improving by stealing/giving. As they say in the textbook " the author leaves that up to the reader". If I get time I will try to add that.

 

[PRMiller2]

addy and BigRed, I do have control over the table structure, but we are having to put this into production very rapidly (I know, I know...) so the structure is unlikely to change much from where it's at.

Here's what I've got:

table: ClaimsDetail
ClaimsDetailID (long)
NABP (text)
ItemDate (date)
Resolved (boolean)

Sample data:
ID: 74
NABP: 0104985
ItemDate: 20111222
Resolved: 0

Each Item has one row in the database. State is identified with the leading 2 digits of the NABP field (stored as text for reasons I don't want to get into. So, if the NABP field = 01, then the state equals AL, based on this lookup table:

table: StateNABP
StateNABPID (long)
StateIDNumber (Number)
StateAbbrev (text)

Sample Data:
StateNABPID: 1
StateIDNumber: 01
StateAbbrev: AL

So I wrote the following two queries (could probably just do a query/subquery, but...):
qryUnresolvedStates1
SELECT CInt(Left([NABP],2)) AS LeadingNABP
FROM PPPD320P;

qryUnresolvedStates2
SELECT DISTINCT b.StateIDNumber, b.StateName
FROM qryUnresolvedStates1 AS a LEFT JOIN StateNABP AS b ON a.LeadingNABP = b.StateIDNumber
ORDER BY b.StateName;

I identify records that aren't resolved this way. I can then summarize a count, BigRed, and go from there.

Andre, your second assumption is correct: Each day the summary counts may be different, so the way everything plays out, scenario 2 would be the case. Plus, if one staffer is out, the work then must be divvied up among 3 instead of 4 staffers.

MajP... wow, thank you! I will read through that and get back to you!

 

[MazeWorX]

MajP strikes again

HTH << MaZeWorX >> "I have not failed I have only found ten thousand ways that don't work" <<Edison>>

 

[MajP]

I cleaned this up some and here is the demo.

http://www.4shared.com/office/jXab47LU/MajPAssignments.html

In the demo there are three tables
tblRequirements7
tblRequirements50
tblRequirements200

The first table is the original problem set
The second is 50 states with possible calls per state from 0 - 100
The third is a notional 200 "state" with required calls from 0 - 1000

In order to see this work rename one of those to "tblRequirements"
In the form first select "Initialize", then choose "Improve". This will show the swaps and the improving Standard dev

I did not try to add a steal/give function but the swap works pretty well. Less then your 7 assignments and this may not work very well. More then a thousand and it may not run.

The alogrithm is neither optimal or efficient. It can probably handle up to a thousand different assignments. With 200 it takes about 40 seconds to improve. With 200 requirements the starting Sdev is 312 and the improved is 1.4. The difference in staffer with the most calls compared to staffer with the least calls goes from about 730 down to 3. Probably not going to get a lot of complaints with one staffer having to call 24,629 and the other 24,626.

Here is the basic algorithm

Sort the required assignments by required number of calls
Deal out Assignments
Do while able to improve
Get Staffer with Most total calls
If Staffer has more than the avg
Try to improve by swapping down with someone who has less than avg
else
Try to improve by swapping up with someone who has more than avg
end if
Next Staffer
Loop while improving


SwapUp
for the current Staffer get their smallest assignment
get biggest assignment from other staffers that have more than avg
if biggest available greater then smallest assignment
Try to improve by swapping
(decrease the Standarddev among total assignments)
end if
next other staffer largest assignments
next current staffer smallest assignment


Here is the updated code.

Option Compare Database
Option Explicit
Public TxtOut As TextBox

Public Sub InitialAssignments()
  Dim RSState As DAO.Recordset
  Dim RSStaffers As DAO.Recordset
  Dim RSAssignment As DAO.Recordset
  Dim strSql As String
  Dim StafferID As Long
  Dim StateID As String
  
  ClearAssignments
  Set RSState = CurrentDb.OpenRecordset("SELECT * FROM tblRequirements ORDER BY RequiredCalls")
  Set RSStaffers = CurrentDb.OpenRecordset("SELECT * FROM tblStaffers ORDER BY StafferID")

  Do While Not RSState.EOF
      If RSStaffers.EOF Then RSStaffers.MoveFirst
      StateID = RSState!StateID
      StafferID = RSStaffers!StafferID
      RSStaffers.MoveNext
      strSql = "INSERT INTO tblAssignments (StafferID, StateID) VALUES (" & StafferID & ", '" & StateID & "')"
      CurrentDb.Execute strSql
    RSState.MoveNext
  Loop
  MsgBox "Initial Assignments"
End Sub
Public Sub ClearAssignments()
  Dim strSql As String
  strSql = "Delete * from tblAssignments"
  CurrentDb.Execute strSql
End Sub

Public Sub ImproveBySwapping()
  Dim RSTotals As DAO.Recordset
  Dim strSql As String
  Dim StafferID As Long
  Dim TotalCalls As Long
  Dim AvgCalls As Double
  Dim DiffFromAvg As Double
  Dim improved As Boolean
   'kick start
  improved = True
  Do While improved
    improved = False
    Set RSTotals = CurrentDb.OpenRecordset("Select * from qryStafferTotals ORDER BY SumOfRequiredCalls")
  Do While Not RSTotals.EOF
     StafferID = RSTotals!StafferID
     TotalCalls = GetTotalCalls(StafferID)
     AvgCalls = GetAvgCalls
     DiffFromAvg = AvgCalls - TotalCalls
     If DiffFromAvg > 0 Then
       'Can possibly improve by adding more
       improved = TryToSwapForMore(StafferID)
       'If improved Then RSTotals.MoveFirst
     ElseIf DiffFromAvg < 0 Then
       'Can possibly improve by reducing
        improved = TryToSwapForLess(StafferID)
        'If improved Then RSTotals.MoveFirst
     End If
     TxtOut = TxtOut & "Staffer " & StafferID & " TotalCalls " & TotalCalls & " AvgCalls " & AvgCalls & vbCrLf
     RSTotals.MoveNext
  Loop
  Loop
  MsgBox "Done Swaps"
   TxtOut = TxtOut & "StandardDev: " & GetCurrentSDev
End Sub

Public Function TryToSwapForMore(StafferID As Long) As Boolean
  Dim PriorSDev As Double
  Dim RSMyAssignments As DAO.Recordset
  Dim RSAvailableAssignments As DAO.Recordset
  Dim GiveState As String
  Dim GiveAmount As Long
  Dim TakeState As String
  Dim TakeAmount As Long
  Dim TakeStaffer As Long
  Dim isSwapped As Boolean
  PriorSDev = GetCurrentSDev
  Set RSMyAssignments = CurrentDb.OpenRecordset("Select * from QryAssignments where StafferID = " & StafferID & " ORDER BY RequiredCalls")
  Set RSAvailableAssignments = CurrentDb.OpenRecordset("Select * from QryAssignments where StafferID <> " & StafferID & " AND StafferID not in (SELECT StafferID From qryStaffersLessThanAverage) ORDER BY RequiredCalls Desc")
  
  Do While Not RSMyAssignments.EOF
    GiveState = RSMyAssignments!StateID
    GiveAmount = RSMyAssignments!RequiredCalls
    If GetAvgCalls <= GetTotalCalls(StafferID) Then Exit Function
    Do While Not RSAvailableAssignments.EOF And Not isSwapped
      TakeState = RSAvailableAssignments!StateID
      TakeAmount = RSAvailableAssignments!RequiredCalls
      TakeStaffer = RSAvailableAssignments!StafferID
      
      If TakeAmount > GiveAmount Then
        PriorSDev = GetCurrentSDev
       ' Debug.Print "GIVE: " & GiveState & " " & GiveAmount
       ' Debug.Print "TAKE: " & TakeState & " " & TakeAmount
        SwapAssignments StafferID, TakeStaffer, GiveState, TakeState
        'Debug.Print PriorSDev & " " & GetCurrentSDev
        If PriorSDev - GetCurrentSDev < 0.0001 Then
          'SwapBack
         ' Debug.Print "swapBack"
          SwapAssignments StafferID, TakeStaffer, TakeState, GiveState
        Else
          TxtOut = TxtOut & "Swapped Up: Staffer " & StafferID & " Give: " & GiveState & " " & GiveAmount & " Staffer " & TakeStaffer & " Take: " & TakeState & " " & TakeAmount & vbCrLf
          TxtOut = TxtOut & "SDev: " & GetCurrentSDev & vbCrLf & vbCrLf
          isSwapped = True
          TryToSwapForMore = True
        End If
      End If
      
      RSAvailableAssignments.MoveNext
    Loop
    RSMyAssignments.MoveNext
  Loop
End Function

Public Function TryToSwapForLess(StafferID As Long) As Boolean
  Dim PriorSDev As Double
  Dim RSMyAssignments As DAO.Recordset
  Dim RSAvailableAssignments As DAO.Recordset
  Dim GiveState As String
  Dim GiveAmount As Long
  Dim TakeState As String
  Dim TakeAmount As Long
  Dim TakeStaffer As Long
  Dim isSwapped As Boolean
  PriorSDev = GetCurrentSDev
  Set RSMyAssignments = CurrentDb.OpenRecordset("Select * from QryAssignments where StafferID = " & StafferID & " ORDER BY RequiredCalls Desc")
  Set RSAvailableAssignments = CurrentDb.OpenRecordset("Select * from QryAssignments where StafferID <> " & StafferID & " AND StafferID not in (SELECT StafferID From qryStaffersMoreThanAverage)ORDER BY RequiredCalls")
  
  Do While Not RSMyAssignments.EOF
    GiveState = RSMyAssignments!StateID
    GiveAmount = RSMyAssignments!RequiredCalls
    If GetAvgCalls >= GetTotalCalls(StafferID) Then Exit Function
    Do While Not RSAvailableAssignments.EOF And Not isSwapped
      TakeState = RSAvailableAssignments!StateID
      TakeAmount = RSAvailableAssignments!RequiredCalls
      TakeStaffer = RSAvailableAssignments!StafferID
      
      If TakeAmount < GiveAmount Then
        PriorSDev = GetCurrentSDev
       ' Debug.Print "GIVE: " & GiveState & " " & GiveAmount
       ' Debug.Print "TAKE: " & TakeState & " " & TakeAmount
        SwapAssignments StafferID, TakeStaffer, GiveState, TakeState
        'Debug.Print PriorSDev & " " & GetCurrentSDev
        If PriorSDev - GetCurrentSDev < 0.0001 Then
          'SwapBack
         ' Debug.Print "swapBack"
          SwapAssignments StafferID, TakeStaffer, TakeState, GiveState
        Else
          TxtOut = TxtOut & "Swapped Down: Staffer " & StafferID & " Give: " & GiveState & " " & GiveAmount & " Staffer " & TakeStaffer & " Take: " & TakeState & " " & TakeAmount & vbCrLf
          TxtOut = TxtOut & "SDev: " & GetCurrentSDev & vbCrLf & vbCrLf
          isSwapped = True
          TryToSwapForLess = True
        End If
      End If
      
      RSAvailableAssignments.MoveNext
    Loop
    RSMyAssignments.MoveNext
  Loop
  
End Function

Public Sub SwapAssignments(GiveStaffer As Long, TakeStaffer As Long, GiveState As String, TakeState As String)
  Dim strSql As String
  strSql = " UPDATE tblAssignments SET StafferID = " & GiveStaffer & " WHERE StateID= '" & TakeState & "'"
 ' Debug.Print strSql
  CurrentDb.Execute strSql
  strSql = " UPDATE tblAssignments SET StafferID = " & TakeStaffer & " WHERE StateID= '" & GiveState & "'"
  'Debug.Print strSql
  CurrentDb.Execute strSql
End Sub

Public Function GetCurrentSDev() As Double
  GetCurrentSDev = DLookup("STdevRequiredCalls", "qryStats")
End Function

Public Function GetAvgCalls() As Double
  GetAvgCalls = DLookup("avgRequiredCalls", "qryStats")
End Function

Public Function GetTotalCalls(StafferID As Long) As Long
  GetTotalCalls = DLookup("SumOfRequiredCalls", "qryStafferTotals", "StafferID = " & StafferID)
End Function

 

[MajP]

There was a problem here. As you cycle through the staffers improving each staffers assignments and if there is an improvement you want to come back and do it all over again starting with the first staffer.
The way it was originally written was if you improved along the way, but the last staffer did not improve then it kicked out of the loop. See the changes.

Public Sub ImproveBySwapping()
  Dim RSTotals As DAO.Recordset
  Dim strSql As String
  Dim StafferID As Long
  Dim TotalCalls As Long
  Dim AvgCalls As Double
  Dim DiffFromAvg As Double
  Dim improved As Boolean
  Dim [b]improvedInLoop[/b] As Boolean
  'kick start
  improvedInLoop = True
  Do While [b]improvedInLoop[/b]
    [b]improvedInLoop = False[/b]
    Set RSTotals = CurrentDb.OpenRecordset("Select * from qryStafferTotals ORDER BY SumOfRequiredCalls")
    RSTotals.MoveFirst
  Do While Not RSTotals.EOF
     StafferID = RSTotals!StafferID
     TotalCalls = GetTotalCalls(StafferID)
     AvgCalls = GetAvgCalls
     DiffFromAvg = AvgCalls - TotalCalls
     If DiffFromAvg > 0 Then
       'Can possibly improve by adding more
       improved = TryToSwapForMore(StafferID)
     ElseIf DiffFromAvg < 0 Then
       'Can possibly improve by reducing
        improved = TryToSwapForLess(StafferID)
     End If
   [b] If improved Then improvedInLoop = True [/b]
     TxtOut = TxtOut & "Staffer " & StafferID & " TotalCalls " & TotalCalls & " AvgCalls " & AvgCalls & vbCrLf
     RSTotals.MoveNext
    Loop
  Loop
  MsgBox "Done Swaps"
   TxtOut = TxtOut & "StandardDev: " & GetCurrentSDev
End Sub

 

[PRMiller2]

MajP, I don't know why the title after your name is "TechnicalUser." If you're a technical user, then I'm a knuckle-dragging prehistoric infant!

Thank you very, very much for this incredible series of posts! I am astonished and humbled by how quickly you put this together, and how kind you were to share this with me and the rest of the forum.

I know you offer help all over the place, but that only makes the fact that you dedicated your time to this all the more generous.

I was given requirements and tasked with putting a multi-user database into production in less than a week, on a network with suboptimal performance and business needs that will continue to change. The requirement that drove the plea for help on this particular post of mine had been relegated to the back burner -- I just figured there was no way I would add this functionality for quite some time.

Thank you once again!