randomly allocating client relationship managers to different clients

[nmusoke17]

I have a list of over 1000 clients I want to allocate to 6 client relationship managers (CRMs) randomly in an equitable way. These clients have varying amounts to pay and these CRMs have to follow-ups with them such that the money is paid on time. How do I randomly allocate these CRMs to the different clients equitably such that all of them view it as a fair distribution in terms of the number of clients and amounts to be followed up each is allocated

 

[ranman256]

paste this code into a module

make a sheet called : Managers (see image)
make a sheet called : Clients
the Tier column is used to put clients into a blocks with money range, so each manager gets high and low value clients
or set all tiers to the same value

run macro: genThePicks
and it will divide the clients.

Public Sub genThePicks()
Dim colMgrs As New Collection, colClients As New Collection, colTiers As New Collection, colClientTier As New Collection
Dim m As Integer, c As Integer, iRnd As Integer, r As Integer, t As Integer, i As Integer
Dim vMgr, vVal, vCli, vCliTier
Dim iCliPerMgr As Integer
Dim sTier As String, sKey As String
Dim bFound As Boolean

On Error GoTo errGen

'===== collect managers
Sheets("managers").Select
Range("A2").Select
While ActiveCell.Value <> ""
    vMgr = ActiveCell.Value
    colMgrs.Add vMgr, vMgr

    ActiveCell.Offset(1, 0).Select ' next row
Wend

'===== collect clients & tiers
Sheets("Clients").Select
Range("A2").Select
While ActiveCell.Value <> ""
    vCli = ActiveCell.Value
    sTier = ActiveCell.Offset(0, 1).Value
    
    sKey = vCli & "," & sTier
    colClientTier.Add sKey, sKey
    
    'colClients.Add vCli, vCli
    colTiers.Add sTier, sTier

    ActiveCell.Offset(1, 0).Select ' next row
Wend

iCliPerMgr = colClients.Count \ colMgrs.Count

'==== make result manager sheets
For m = 1 To colMgrs.Count
    Sheets.Add
    ActiveSheet.Name = colMgrs(m)
Next

'------split up clients to mgrs using money tiers
For t = 1 To colTiers.Count
    sTier = colTiers(t)
    
      'fill the client collection with only clients w that 1 tier to pick from
    Set colClients = New Collection
    For c = 1 To colClientTier.Count
         vCliTier = colClientTier(c)
         
         If InStr(vCliTier, sTier) > 0 Then
            sKey = Left(vCliTier, InStr(vCliTier, ",") - 1)
            colClients.Add sKey, sKey
         End If
        
    Next
    
    For m = 1 To colMgrs.Count
        vMgr = colMgrs(m)
        Sheets(vMgr).Select
        
         GoSub getRndClient
              
              'assign client
            vCli = colClients(r)
            ActiveCell.Value = vCli
            ActiveCell.Offset(1, 0).Select ' next row
            
            colClients.Remove vCli
   Next m
Next t


endit:
Set colMgrs = Nothing
Set colTiers = Nothing
Set colClients = Nothing
Set colClientTier = Nothing

MsgBox "done"

Exit Sub

getRndClient:
    r = getRndNum(colClients.Count)
    vCliTier = colClientTier(r)
Return

errGen:
Select Case Err
  Case 457
    Resume Next
  Case Else
    MsgBox Err.Description, , Err
End Select
End Sub


Private Function getRndNum(ByVal piLimit As Integer)
getRndNum = Int(piLimit * Rnd + 1)
End Function