很难回答你的问题。
问题 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 列的其余部分可用于标题。第一个空白列右侧的列未检查，可用于 cmets。矩阵下方的区域用于答案。
我有一个控制例程，它加载数据并调用不知道工作表的重新分配例程。
再分配例程接受最大列值和矩阵作为参数，并就地更新矩阵。
一般来说，我相信应满足客户的要求。我可能会轻轻地将他们推向我认为他们需要的方向，但他们经常必须看到第一个版本才能理解为什么我怀疑它可能不是他们需要的。在这里，我打破了我自己的规则，给了你我认为你需要的东西。如果您确实需要均匀分布，可以轻松调整此代码来创建它，但我希望您首先看到“现实”分布。
我在我的代码中放置了 cmets，但算法的细节可能不清楚。尝试选择重新分发问题的代码。如果看起来正确，我可以提供进一步的解释和算法的细节部分，可能需要微调。
我没有删除我的诊断代码。
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