Например, есть список активных клиентов по территориям и список менеджеров (продавцов) по территориям:
Клиенты: |
Менеджеры (продавцы):
|
|
|
Например, требуется равномерно распределить базу клиентов между менеджерами, внутри каждой территории.
Пусть на территории 1 есть 7 клиентов и 3 менеджера.
Тогда равномерное распределение выглядело бы примерно так:
Одному менеджеру 3 клиента, второму 2, третьему 2:
Например, реализован следующий дизайн формы со списком клиентов и кнопками управления:
Под кнопку "Назначить менеджера клиенту" требуется разработать код равномерного распределения клиентов по менеджерам в цикле (заполнение полей формы SalesPersonID, SalesPersonName и также поля Error, если в процессе возникла ошибка).
По результатам распределения выдать окно сколько клиентов распределено успешно и сколько с ошибками:
|
|
Под кнопку "Открыть сводку распределения клиентов" требуется разработать код открытия формы -- сводной диаграммы по данным о клиентах и назначенных на них менеджеров:
Под кнопку "Очистить результат назначения" требуется убрать назначенных менеджеров (очистить поля на форме в цикле):
|
|
Равномерное распределение клиентов по менеджерам в цикле
Реализация равномерности с помощью запроса выдать менеджера по самой ранней дате LAST_ASSIGNED, где LAST_ASSIGNED -- дата и время назначения менеджеру очередного клиента (точность хранения времени одна сотая секунды):
SalesPerson_by_Territory_QRY --запрос -- список продавцов по территориям
PARAMETERS TerritoryID_PARAM Short; -- на заданное значение TerritoryID вернуть продавца с самой ранней датой LAST_ASSIGNED
SELECT TOP 1 SalesPerson_TAB.SalesPersonID, SalesPerson_TAB.SalesPersonName, SalesPerson_TAB.Territory_ID, Territory_TAB.Territory_Name, SalesPerson_TAB.LAST_ASSIGNED
FROM Territory_TAB
INNER JOIN SalesPerson_TAB ON Territory_TAB.Territory_ID = SalesPerson_TAB.Territory_ID
WHERE (((SalesPerson_TAB.Territory_ID)=[TerritoryID_PARAM]))
ORDER BY SalesPerson_TAB.LAST_ASSIGNED;
LAST_ASSIGNED по каждому назначенному менеджеру помечается новым значением, при этом вызов процедуры Wait на заданное количество сотых секунды обеспечивает её уникальность.
Private Sub DISTRIBUTE_CUSTOMERS_Click()
If Recordset.EOF Then 'рекордсет формы
MsgBox "Нет записей", vbExclamation
Else
Recordset.MoveFirst
Dim nSuccess As Integer 'количество успешно распределённых клиентов (назначен менеджер)
Dim nError As Integer 'количество ошибок при распределении (не назначен менеджер)
Do While Not Recordset.EOF 'до конца рекордсета
If IsNull(Recordset!SalesPersonID) Then 'если клиенту менеджер ещё не назначен
Recordset.Edit 'перевести текущую запись рекордсета в режим редактирования
On Error GoTo Err 'при ошибке перейти к err:
Dim SalesPersonID As Integer
Dim SalesPersonName As String
'функция принимает TerritoryID и вычисляет SalesPersonID
Call SalesPersonRoundRobin(Recordset!TerritoryID, SalesPersonID, SalesPersonName)
Recordset!SalesPersonID = SalesPersonID 'заполнить поле SalesPersonID значением переменной SalesPersonID
Recordset!SalesPersonName = SalesPersonName 'заполнить поле SalesPersonName значением переменной SalesPersonName
Recordset!ERROR = Null
nSuccess = nSuccess + 1 'количество успешно распределённых дел + 1
GoTo OK 'продолжить в OK-е
Err:
'заполнить поле формы "ERROR" если в процессе возникла ошибка
Recordset!ERROR = CErr() 'CErr берёт текущий exception и делает из него строку
nError = nError + 1 'количество ошибок при распределении + 1
Resume OK 'продолжить в OK-е (если не перейти в ОК, то ошибка на следующей итерации цикла вызовет переход в отладчик (Debug на экране))
OK:
Recordset.Update
End If
Recordset.MoveNext
Loop
Me.Refresh 'обновить обновлённую последнюю запись на экране
Recordset.MoveFirst
If nSuccess = 0 And nError = 0 Then
MsgBox "Распределение клиентов по менеджерам:", vbExclamation
Else
Dim status As Integer 'переменная вида сообщения пользователю на экран
If nError = 0 Then
status = vbInformation
Else
status = vbExclamation
End If
MsgBox "Распределение клиентов по менеджерам:" & vbCrLf _
& vbCrLf _
& "успешно: " & nSuccess & vbCrLf _
& "ошибочно: " & nError, _
status, softname
End If
End If
End Sub
'процедура принимает TerritoryID и вычисляет SalesPersonID и SalesPersonName
'заполняет данные поля SalesPersonID и SalesPersonName в форме
Sub SalesPersonRoundRobin(TerritoryID As Variant, ByRef SalesPersonID As Integer, ByRef SalesPersonName As String)
If IsNull(TerritoryID) Then 'если в текущей записи по какой-то причине нет значения TerritoryID
Err.Raise 1, "Internal error", "TerritoryID must be filled in but is null" 'поднять exception
End If
'изначальное значение
SalesPersonID = 0
SalesPersonName = ""
Dim qdf As DAO.QueryDef
Set qdf = CurrentDb.QueryDefs!SalesPerson_by_Territory_QRY 'запрос -- список продавцов по территориям
'Запрос отдаёт того продавца (SalesPerson), у которого дата LAST_ASSIGNED самая старая (ему давно не передавали клиентов)
'Сделано с помощью вызова SELECT TOP 1 и сортировки по полю LAST_ASSIGNED
'(дата LAST_ASSIGNED обновляется по ходу программы)
qdf.Parameters!TerritoryID_PARAM = TerritoryID
'в запросе SalesPerson_by_Territory_QRY параметр именован как TerritoryID_PARAM
'присваиваем ему значение из входящего параметра функции
Dim rs As DAO.Recordset
Set rs = qdf.OpenRecordset 'выполнить запрос SalesPerson_by_Territory_QRY
'Check to see if the recordset actually contains rows
If Not (rs.EOF And rs.BOF) Then
SalesPersonName = rs!SalesPersonName 'найденный SalesPersonName (вернуть в параметр процедуры ByRef)
SalesPersonID = rs!SalesPersonID 'найденный SalesPersonName (вернуть в параметр процедуры ByRef)
Wait 0.01 'обновляя дату LAST_ASSIGNED нельзя попасть в ту же долю секунды, т.к. точность хранения времени в LAST_ASSIGNED одна сотая секунды)
rs.Edit 'переключить запись рекордсета в режим редактирования
'положить новое значение LAST_ASSIGNED в запрос SalesPerson_by_Territory_QRY
rs!LAST_ASSIGNED = TimeInMS 'функция TimeInMS выдает строку системного времени в формате дата и время с точностью до сотых долей секунды
rs.Update 'сохранить изменения
End If
rs.Close 'закрыть рекордсет
Set rs = Nothing 'очистить рекордсет
qdf.Close 'закрыть запрос
Set qdf = Nothing 'очистить переменную запроса
'в эту ситуацию можно провалиться из первого IF-а или если почему-то NULL-ы в запросе SalesPerson_by_Territory_QRY
If SalesPersonName = "" Then
Err.Raise 1, CErr
End If
End Sub
'выдает строку системного времени в формате дата и время с точностью до сотых долей секунды
Public Function TimeInMS() As String
TimeInMS = Strings.Format(now, "yyyy-mm-dd HH:nn:ss") & "." & Strings.Right(Strings.Format(Timer, "#0.00"), 2)
End Function
Sub Wait(seconds As Single)
Dim now As Long
now = Timer()
Do
DoEvents
Loop While (Timer < now + seconds)
End Sub
Sub test()
Dim a As String
Dim b As String
a = TimeInMS
Wait (0.001)
b = TimeInMS
MsgBox a & " " & b
End Sub
Public Function CErr() As String 'представляет ошибку программы / exception в виде строки
CErr = "Error: " & CStr(Err.Number) & "; " & Err.Source & "; " & Err.Description
'например Error: 3421; DAO.Field; Ошибка преобразования типа данных.
End Function