Добрый день, дорогие товарищи, Задача следующая: Есть потребность проектов в ресурсах отдела (людях). Ресурсы проекта ограничены. Проекты, конечно же, надо сделать в тот срок, который стоит по плану. Проекты начнутся тогда, когда запланировано. Вопрос: можно ли распределить проекты так, чтобы они "вмещались" в ежемесячное ограничение ресурсов проектов (строка "Новое распределение"). При этом общую потребность проектов в ресурсах уменьшили в соответствии с максимальными возможностями отделов.
Данную задачу могу выполнить только несколькими последовательными вычислениями. При этом все равно приходится делать допущения и распределять автоматом кое-как или даже вручную. Есть ли более быстрый способ? Возможно макрос, который: 1. Определит месяц старта проектов, 2. Определит длительность проектов, 3. Шаг за шагом будет распределять проекты по месяцам, сверяюсь с максимальной мощностью отдела в этом месяце. 4. Выдаст сообщение, что такое распределение при заданных фиксированных показателях невозможно. 5. Предложит минимально возможные фиксированные показатели, при которых такое распределение возможно.
Не уверен, что вообще такой алгоритм возможно сделать)
К сожалению, слишком много действий необходимо сделать (в примере один отдел, а так их 50 и проектов под 100 для каждого отдела), чтобы это заработало в MS Project.
Добрый день, Сроки проектов можно вычислить исходя из месяца начала и длительности (это месяцы в которых есть заполненные ячейки). Мощность отделов указана в строчке "Новое распределение".
Dim dSrok As Object
Dim dZatr As Object
'
Sub Main()
Job1_init
Job2_sort
Job3
End Sub
'
Sub Job1_init()
Set dSrok = CreateObject("Scripting.Dictionary")
Set dZatr = CreateObject("Scripting.Dictionary")
Dim a As Variant
a = ActiveSheet.Range("A1:O8")
Dim y As Long
Dim x As Integer
For y = 4 To 8
x = UBound(a, 2) - 1
Do
If Not IsEmpty(a(y, x)) Then Exit Do
If x = 3 Then Exit Do
x = x - 1
Loop
dSrok(a(y, 2)) = x
dZatr(a(y, 2)) = CInt(a(y, UBound(a, 2)))
Next
End Sub
'
Sub Job2_sort()
Dim sh As Worksheet
Set sh = Worksheets.Add
With sh
.Cells(1, 1).Resize(dSrok.Count, 1) = Application.Transpose(dSrok.keys())
.Cells(1, 2).Resize(dSrok.Count, 1) = Application.Transpose(dSrok.Items())
With .Sort
.SortFields.Clear
.SortFields.Add Key:=Cells(1, 2).Resize(dSrok.Count, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Cells(1, 1).Resize(dSrok.Count, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Cells(1, 1).Resize(dSrok.Count, 2)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Dim a As Variant
a = .Cells(1, 1).Resize(dSrok.Count, 2)
End With
Set dSrok = CreateObject("Scripting.Dictionary")
Dim y As Long
For y = 1 To UBound(a, 1)
dSrok.Item(a(y, 1)) = a(y, 2)
Next
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
End Sub
'
Sub Job3()
ActiveSheet.Range("C11:N15").ClearContents
ActiveSheet.UsedRange.Calculate
' Dim h As Variant
' h = ActiveSheet.Range("A9:N9")
Dim r As Range
Set r = ActiveSheet.Range("A11:B15")
Dim a As Variant
a = r
Dim y As Long
Dim x As Byte
Dim p As Variant
Dim zt As Integer
Dim dt As Integer
Dim fuckup As Object
Set fuckup = CreateObject("Scripting.Dictionary")
For Each p In dSrok.keys
y = 1
Do
If p = a(y, 2) Then Exit Do
y = y + 1
If y > UBound(a, 1) Then
MsgBox "Не найден " & p, vbInformation
Exit Sub
End If
Loop
zt = dZatr.Item(p)
x = 3
Do
dt = Cells(9, x).Value - Cells(10, x).Value
If dt < 0 Then dt = 0
dt = Application.Min(dt, zt)
zt = zt - dt
If dt > 0 Then Cells(11, 1).Cells(y, x).Value = dt
If zt = 0 Then Exit Do
x = x + 1
If x > Range("N1").Column Then
fuckup.Item(p) = 0
Exit Do
End If
Loop
Next
If fuckup.Count > 0 Then
MsgBox "Going to fuckup" & vbCrLf & Join(fuckup.keys(), vbCrLf), vbInformation
End IfEnd Sub
Пункты 1-4 макросом. Такое можно сделать и формулами.