Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Распределение загрузки отдела по проектам в соответствии с ресурсной возможностью отдела
 
#1
20.02.2020 19:54:05
Добрый день, дорогие товарищи,
Задача следующая: Есть потребность проектов в ресурсах отдела (людях). Ресурсы проекта ограничены. Проекты, конечно же, надо сделать в тот срок, который стоит по плану. Проекты начнутся тогда, когда запланировано.
Вопрос: можно ли распределить проекты так, чтобы они "вмещались" в ежемесячное ограничение ресурсов проектов (строка "Новое распределение"). При этом общую потребность проектов в ресурсах уменьшили в соответствии с максимальными возможностями отделов.

Данную задачу могу выполнить только несколькими последовательными вычислениями. При этом все равно приходится делать допущения и распределять автоматом кое-как или даже вручную. Есть ли более быстрый способ? Возможно макрос, который:
1. Определит месяц старта проектов,
2. Определит длительность проектов,
3. Шаг за шагом будет распределять проекты по месяцам, сверяюсь с максимальной мощностью отдела в этом месяце.
4. Выдаст сообщение, что такое распределение при заданных фиксированных показателях невозможно.
5. Предложит минимально возможные фиксированные показатели, при которых такое распределение возможно.

Не уверен, что вообще такой алгоритм возможно сделать)
Изменено: Guynotgay - 20.02.2020 20:02:20
 
 
 
#2
20.02.2020 20:06:31
MS Project заточен под ваш запрос
 
 
 
#3
20.02.2020 20:26:43
К сожалению, слишком много действий необходимо сделать (в примере один отдел, а так их 50 и проектов под 100 для каждого отдела), чтобы это заработало в MS Project.
 
 
 
#4
21.02.2020 09:22:55
Представленных данных недостаточно.
Нужны ещё:
- сроки проектов
- мощности отделов.
Изменено: МатросНаЗебре - 21.02.2020 09:32:28
 
 
 
#5
21.02.2020 13:23:04
Добрый день,
Сроки проектов можно вычислить исходя из месяца начала и длительности (это месяцы в которых есть заполненные ячейки).
Мощность отделов указана в строчке "Новое распределение".
Изменено: Guynotgay - 21.02.2020 13:23:15
 
 
 
#6
21.02.2020 13:34:23
В смысле, последняя заполненная ячейка и есть требуемый срок завершения проекта.
 
 
 
#7
21.02.2020 14:35:25
Код
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 макросом. Такое можно сделать и формулами.
 
 
 
Страницы: 1
Наверх