Сложно ответить на ваш вопрос.
Задача 1
ExpColMaxDays = CalculatingManDays(ExpRows, ColArray(i))
Что такое CalculatingManDays и ExpRows?
Задача 2
Что такое RowArray и ColArray? Это кажется очень сложным способом доступа к блоку ячеек. Следующее легче, если нет никакого значения для этого подхода, который я пропускаю.
For RowCrnt = RowTop To RowBottom
For ColCrnt = ColLeft to ColRight
... Cells(RowCrnt, ColCrnt) ...
Задача 3
Если вы действительно хотите равномерно распределить значения по прямоугольнику, я предлагаю:
Sub Rearrange(RowTop As Long, ColLeft As Long, _
RowBottom As Long, ColRight As Long)
' I assume the cell values are all integers without checking
Dim CellValue As Long
Dim ColCrnt As Long
Dim NumCells As Long
Dim Remainder As Long
Dim RowCrnt As Long
Dim TotalValue As Long
' Calculate the total value
TotalValue = 0
For RowCrnt = RowTop To RowBottom
For ColCrnt = ColLeft To ColRight
TotalValue = TotalValue + Cells(RowCrnt, ColCrnt).Value
Next
Next
' Calculate the standard value for each cell and the remainder which
' will be distributed over the early cells
NumCells = (RowBottom - RowTop + 1) * (ColRight - ColLeft + 1)
CellValue = TotalValue / NumCells
Remainder = TotalValue Mod NumCells
For RowCrnt = RowTop To RowBottom
For ColCrnt = ColLeft To ColRight
If Remainder > 0 Then
Cells(RowCrnt, ColCrnt).Value = CellValue + 1
Remainder = Remainder - 1
Else
Cells(RowCrnt, ColCrnt).Value = CellValue
End If
Next
Next
End Sub
Новый раздел в ответ на уточнение проблемы
Читая все ваши вопросы, я думаю, что у меня есть понимание того, что вы пытаетесь. Если мое понимание правильное, у меня была похожая проблема.
Один из моих работодателей потребовал, чтобы мы вели учет времени, потраченного на каждый вид деятельности для проекта. Были пики (потому что мы работали по вечерам и выходным, чтобы уложиться в сроки) и минимумы (потому что мы не могли продвигать ни один из наших проектов), но электронная система, в которую мы вводили наши расписания, требовала от нас не более 37,5 часов в неделю. Работодатель хотел записать правильное время для каждого проекта и вида деятельности, поэтому нам пришлось распределить фактическое время между пиками и впадинами, не перемещая время из одного вида деятельности или проекта в другой.
Алгоритм, который я использовал для распределения своего времени, был следующим:
- Если общее время за период не было требуемым кратным 37,5, время было перенесено с самых высоких пиков или самых глубоких впадин на первую неделю следующего периода.
- В каждом цикле основного цикла выбирается неделя с наибольшим итогом. Если это общее количество было меньше или равно 37,5 часам, алгоритм завершался.
- Время, записанное для каждой задачи (вид деятельности и проект), будет сокращено, так что новый итог составит 37,5, а новая пропорция времени каждого задания к общему времени недели будет максимально похожа на исходную пропорцию.
- Время, вычитаемое из каждого задания, будет делиться поровну между неделей до и неделей позже, если только эта неделя не была корректно правильной, и в этом случае следующая нескорректированная неделя в том же направлении получила дополнительное время.
Мой код не выполняет шаг 1. Если общее время превышает допустимый максимум, проблема отклоняется как неразрешимая. Результат шагов со 2 по 4 не является равномерным разбросом ваших примеров, потому что время перемещается от пика к ближайшему желобу и потому что время не перемещается из ряда в ряд. В конце процесса все пики были удалены, и любые оставшиеся впадины могут быть где угодно в течение периода. Это дает более реалистичный вид и показывает, как время могло бы быть выделено для задач, если недельный максимум не был превышен.
Для тестирования я загрузил каждый лист с проблемой. Ячейка A1 содержит максимальное значение столбца. Матрица начинается в ячейке B2 и продолжается до первого пустого столбца и первой пустой строки. Остальная часть строки 1 и столбца A может использоваться для заголовков, если это необходимо. Столбцы справа от первого пустого столбца не проверяются и могут использоваться для комментариев. Область под матрицей используется для ответа.
У меня есть управляющая подпрограмма, которая загружает данные и вызывает подпрограмму перераспределения, которая не знает о рабочих листах.
Процедура перераспределения принимает максимальное значение столбца и матрицу в качестве параметров и обновляет матрицу на месте.
В общем, я верю в то, чтобы дать клиенту то, о чем он просил. Я могу осторожно подтолкнуть их в направлении того, что, на мой взгляд, им нужно, но слишком часто они должны увидеть первую версию, прежде чем поймут, почему я подозреваю, что это может быть не то, что им нужно. Здесь я нарушил свое собственное правило и дал вам то, что, как мне кажется, вам нужно. Если вам действительно нужен равномерный дистрибутив, этот код можно легко адаптировать для его создания, но я хочу, чтобы вы сначала увидели «реалистичный» дистрибутив.
Я разместил комментарии в своем коде, но тонкости алгоритма могут быть неясными. Попробуйте код на выбор проблем перераспределения. Если все выглядит правильно, я могу дать дополнительные объяснения и детализировать части алгоритма, которые могут потребовать точной настройки.
Я не удалил свой диагностический код.
Option Explicit
Sub Control()
' For each worksheet
' * Validate and load maximum column value and matrix.
' * If maximum column value or matrix are faulty, output a message
' to below the matrix.
' * Call the redistribution algorithm.
' * Store result below the original matrix.
Dim Addr As String
Dim ColCrnt As Long
Dim ColMatrixLast As Long
Dim ErrMsg As String
Dim Matrix() As Long
Dim MatrixMaxColTotal As Long
Dim Pos As Long
Dim RowCrnt As Long
Dim RowMatrixLast As Long
Dim RowMsg As Long
Dim TotalMatrix As Long
Dim WSht As Worksheet
For Each WSht In Worksheets
ErrMsg = ""
With WSht
' Load MaxCol
If IsNumeric(.Cells(1, 1).Value) Then
MatrixMaxColTotal = Int(.Cells(1, 1).Value) ' Ignore any decimal digits
If MatrixMaxColTotal <= 0 Then
ErrMsg = "Maximum column value (Cell A1) is not positive"
End If
Else
ErrMsg = "Maximum column value (Cell A1) is not numeric"
End If
If ErrMsg = "" Then
' Find dimensions of matrix
If IsEmpty(.Cells(2, 2).Value) Then
ErrMsg = "Top left cell of matrix (Cell B2) is empty"
Else
Debug.Print .Name
If Not IsEmpty(.Cells(2, 3).Value) Then
' Position to last non-blank cell in row 2 after B2
ColMatrixLast = .Cells(2, 2).End(xlToRight).Column
Else
' Cell C2 is blank
ColMatrixLast = 2
End If
'Debug.Print ColMatrixLast
If Not IsEmpty(.Cells(3, 2).Value) Then
' Position to last non-blank cell in column 2 after B2
RowMatrixLast = .Cells(2, 2).End(xlDown).Row
Else
' Cell B3 is blank
RowMatrixLast = 2
End If
'Debug.Print RowMatrixLast
If ColMatrixLast = 2 Then
ErrMsg = "Matrix must have at least two columns"
End If
End If
End If
If ErrMsg = "" Then
' Load matrix and validation as all numeric
ReDim Matrix(1 To ColMatrixLast - 1, 1 To RowMatrixLast - 1)
TotalMatrix = 0
For RowCrnt = 2 To RowMatrixLast
For ColCrnt = 2 To ColMatrixLast
If Not IsEmpty(.Cells(RowCrnt, ColCrnt).Value) And _
IsNumeric(.Cells(RowCrnt, ColCrnt).Value) Then
Matrix(ColCrnt - 1, RowCrnt - 1) = .Cells(RowCrnt, ColCrnt).Value
TotalMatrix = TotalMatrix + Matrix(ColCrnt - 1, RowCrnt - 1)
Else
ErrMsg = "Cell " & Replace(.Cells(RowCrnt, ColCrnt).Address, "$", "") & _
" is not numeric"
Exit For
End If
Next
Next
If TotalMatrix > MatrixMaxColTotal * UBound(Matrix, 1) Then
ErrMsg = "Matrix total (" & TotalMatrix & ") > Maximum column total x " & _
"Number of columns (" & MatrixMaxColTotal * UBound(Matrix, 1) & ")"
End If
End If
RowMsg = .Cells(Rows.Count, "B").End(xlUp).Row + 2
If ErrMsg = "" Then
Call Redistribute(MatrixMaxColTotal, Matrix)
' Save answer
For RowCrnt = 2 To RowMatrixLast
For ColCrnt = 2 To ColMatrixLast
.Cells(RowCrnt + RowMsg, ColCrnt).Value = Matrix(ColCrnt - 1, RowCrnt - 1)
Next
Next
Else
.Cells(RowMsg, "B").Value = "Error: " & ErrMsg
End If
End With
Next
End Sub
Sub Redistribute(MaxColTotal As Long, Matrix() As Long)
' * Matrix is a two dimensional array. A row specifies the time
' spent on a single task. A column specifies the time spend
' during a single time period. The nature of the tasks and the
' time periods is not known to this routine.
' * This routine uses rows 1 to N and columns 1 to M. Row 0 and
' Column 0 could be used for headings such as task or period
' name without effecting this routine.
' * The time spent during each time period should not exceed
' MaxColTotal. The routine redistributes time so this is true.
Dim FixedCol() As Boolean
Dim InxColCrnt As Long
Dim InxColMaxTotal As Long
Dim InxColTgtLeft As Long
Dim InxColTgtRight As Long
Dim InxRowCrnt As Long
Dim InxRowSorted As Long
Dim InxTotalRowSorted() As Long
Dim Lng As Long
Dim TotalCol() As Long
Dim TotalColCrnt As Long
Dim TotalMatrix As Long
Dim TotalRow() As Long
Dim TotalRowCrnt As Long
Dim TotalRowRedistribute() As Long
Call DsplMatrix(Matrix)
ReDim TotalCol(1 To UBound(Matrix, 1))
ReDim FixedCol(1 To UBound(TotalCol))
ReDim TotalRow(1 To UBound(Matrix, 2))
ReDim InxTotalRowSorted(1 To UBound(TotalRow))
ReDim TotalRowRedistribute(1 To UBound(TotalRow))
' Calculate totals per column and set all entries in FixedCol to False
For InxColCrnt = 1 To UBound(Matrix, 1)
TotalColCrnt = 0
For InxRowCrnt = 1 To UBound(Matrix, 2)
TotalColCrnt = TotalColCrnt + Matrix(InxColCrnt, InxRowCrnt)
Next
TotalCol(InxColCrnt) = TotalColCrnt
FixedCol(InxColCrnt) = False
Next
' Calculate totals per row
For InxRowCrnt = 1 To UBound(Matrix, 2)
TotalRowCrnt = 0
For InxColCrnt = 1 To UBound(Matrix, 1)
TotalRowCrnt = TotalRowCrnt + Matrix(InxColCrnt, InxRowCrnt)
Next
TotalRow(InxRowCrnt) = TotalRowCrnt
Next
' Created sorted index into totals per row
' This sorted index allows rows to be processed in the total sequence
For InxRowCrnt = 1 To UBound(TotalRow)
InxTotalRowSorted(InxRowCrnt) = InxRowCrnt
Next
InxRowCrnt = 1
Do While InxRowCrnt < UBound(TotalRow)
If TotalRow(InxTotalRowSorted(InxRowCrnt)) > _
TotalRow(InxTotalRowSorted(InxRowCrnt + 1)) Then
Lng = InxTotalRowSorted(InxRowCrnt)
InxTotalRowSorted(InxRowCrnt) = InxTotalRowSorted(InxRowCrnt + 1)
InxTotalRowSorted(InxRowCrnt + 1) = Lng
If InxRowCrnt > 1 Then
InxRowCrnt = InxRowCrnt - 1
Else
InxRowCrnt = InxRowCrnt + 1
End If
Else
InxRowCrnt = InxRowCrnt + 1
End If
Loop
'For InxColCrnt = 1 To UBound(Matrix, 1)
' Debug.Print Right(" " & TotalCol(InxColCrnt), 3) & " ";
'Next
'Debug.Print
'Debug.Print
For InxRowCrnt = 1 To UBound(TotalRow)
Debug.Print Right(" " & TotalRow(InxRowCrnt), 3) & " ";
Next
Debug.Print
For InxRowCrnt = 1 To UBound(TotalRow)
Debug.Print Right(" " & InxTotalRowSorted(InxRowCrnt), 3) & " ";
Next
Debug.Print
Do While True
' Find column with highest total
InxColMaxTotal = 1
TotalColCrnt = TotalCol(InxColMaxTotal)
For InxColCrnt = 2 To UBound(TotalCol)
If TotalColCrnt < TotalCol(InxColCrnt) Then
TotalColCrnt = TotalCol(InxColCrnt)
InxColMaxTotal = InxColCrnt
End If
Next
If TotalColCrnt <= MaxColTotal Then
' Problem solved
Exit Sub
End If
' Find column to left, if any, to which
' surplus can be transferred
InxColTgtLeft = 0
For InxColCrnt = InxColMaxTotal - 1 To 1 Step -1
If Not FixedCol(InxColCrnt) Then
InxColTgtLeft = InxColCrnt
Exit For
End If
Next
' Find column to right, if any, to which
' surplus can be transferred
InxColTgtRight = 0
For InxColCrnt = InxColMaxTotal + 1 To UBound(TotalCol)
If Not FixedCol(InxColCrnt) Then
InxColTgtRight = InxColCrnt
Exit For
End If
Next
If InxColTgtLeft = 0 And InxColTgtRight = 0 Then
' Problem unsolvable
Call MsgBox("Redistribution impossible", vbCritical)
Exit Sub
End If
If InxColTgtLeft = 0 Then
' There is no column to the left to which surplus can be
' redistributed. Give its share to column on the right.
InxColTgtLeft = InxColTgtRight
End If
If InxColTgtRight = 0 Then
' There is no column to the right to which surplus can be
' redistributed. Give its share to column on the left.
InxColTgtRight = InxColTgtLeft
End If
'Debug.Print InxColTgtLeft & " " & InxColMaxTotal & " " & InxColTgtRight
' Calculate new value for each row of the column with maximum total,
' Calculate the value to be redistributed and the new column total
TotalColCrnt = TotalCol(InxColMaxTotal)
For InxRowCrnt = 1 To UBound(TotalRow)
Lng = Round(Matrix(InxColMaxTotal, InxRowCrnt) * MaxColTotal / TotalColCrnt, 0)
TotalRowRedistribute(InxRowCrnt) = Matrix(InxColMaxTotal, InxRowCrnt) - Lng
Matrix(InxColMaxTotal, InxRowCrnt) = Lng
TotalCol(InxColMaxTotal) = TotalCol(InxColMaxTotal) - TotalRowRedistribute(InxRowCrnt)
Next
If TotalCol(InxColMaxTotal) > MaxColTotal Then
' The column has not be reduced by enough.
' subtract 1 from the value for rows with the smallest totals until
' the column total has been reduced to MaxColTotal
For InxRowCrnt = 1 To UBound(TotalRow)
InxRowSorted = InxTotalRowSorted(InxRowCrnt)
Matrix(InxColMaxTotal, InxRowCrnt) = Matrix(InxColMaxTotal, InxRowCrnt) - 1
TotalRowRedistribute(InxRowCrnt) = TotalRowRedistribute(InxRowCrnt) + 1
TotalCol(InxColMaxTotal) = TotalCol(InxColMaxTotal) - 1
If TotalCol(InxColMaxTotal) = MaxColTotal Then
Exit For
End If
Next
ElseIf TotalCol(InxColMaxTotal) < MaxColTotal Then
' The column has be reduced by too much.
' Add 1 to the value for rows with the largest totals until
For InxRowCrnt = 1 To UBound(TotalRow)
InxRowSorted = InxTotalRowSorted(InxRowCrnt)
Matrix(InxColMaxTotal, InxRowCrnt) = Matrix(InxColMaxTotal, InxRowCrnt) + 1
TotalRowRedistribute(InxRowCrnt) = TotalRowRedistribute(InxRowCrnt) - 1
TotalCol(InxColMaxTotal) = TotalCol(InxColMaxTotal) + 1
If TotalCol(InxColMaxTotal) = MaxColTotal Then
Exit For
End If
Next
End If
' The column which did have the hightest total has now beed fixed
FixedCol(InxColMaxTotal) = True
' The values in TotalRowRedistribute must but added to the columns
' identified by InxColTgtLeft and InxColTgtRight
For InxRowCrnt = 1 To UBound(TotalRow)
Lng = TotalRowRedistribute(InxRowCrnt) / 2
Matrix(InxColTgtLeft, InxRowCrnt) = Matrix(InxColTgtLeft, InxRowCrnt) + Lng
TotalCol(InxColTgtLeft) = TotalCol(InxColTgtLeft) + Lng
Lng = TotalRowRedistribute(InxRowCrnt) - Lng
Matrix(InxColTgtRight, InxRowCrnt) = Matrix(InxColTgtRight, InxRowCrnt) + Lng
TotalCol(InxColTgtRight) = TotalCol(InxColTgtRight) + Lng
Next
Call DsplMatrix(Matrix)
Loop
End Sub
Sub DsplMatrix(Matrix() As Long)
Dim InxColCrnt As Long
Dim InxRowCrnt As Long
Dim TotalColCrnt As Long
Dim TotalMatrix As Long
Dim TotalRowCrnt As Long
For InxRowCrnt = 1 To UBound(Matrix, 2)
TotalRowCrnt = 0
For InxColCrnt = 1 To UBound(Matrix, 1)
Debug.Print Right(" " & Matrix(InxColCrnt, InxRowCrnt), 3) & " ";
TotalRowCrnt = TotalRowCrnt + Matrix(InxColCrnt, InxRowCrnt)
Next
Debug.Print " | " & Right(" " & TotalRowCrnt, 3)
Next
For InxColCrnt = 1 To UBound(Matrix, 1)
Debug.Print "--- ";
Next
Debug.Print " | ---"
TotalMatrix = 0
For InxColCrnt = 1 To UBound(Matrix, 1)
TotalColCrnt = 0
For InxRowCrnt = 1 To UBound(Matrix, 2)
TotalColCrnt = TotalColCrnt + Matrix(InxColCrnt, InxRowCrnt)
Next
Debug.Print Right(" " & TotalColCrnt, 3) & " ";
TotalMatrix = TotalMatrix + TotalColCrnt
Next
Debug.Print " | " & Right(" " & TotalMatrix, 3)
Debug.Print
End Sub