我的值可以显示为矩阵：
示例：
5 0 0 11 0 0 0 0 0 0 0
15 5 0 0 11 0 0 0 0 0 0
3 11 5 0 0 0 0 0 0 0 0
Colum sums将是：
23 16 5 11 11 0 0 0 0 0 0
总和将是：66
如果总和应该是6，例如在每一列中从左侧开始填充它，那么在行中分配数字的最佳方法是什么？最后我需要这样的东西：
2 2 2 2 2 2 2 2 2 2 2
2 2 2 2 2 2 2 2 2 2 2
2 2 2 2 2 2 2 2 2 2 2
Colum sums将是：
6 6 6 6 6 6 6 6 6 6 6
总和将是：66
另一个例子，其中列中的总和并不表示均匀分布：
3 3 3 3 3 3 3 3 2 0 0
3 3 3 3 3 3 3 3 0 0 0
2 2 2 2 2 2 2 2 0 0 0
Colum sums将是：
8 8 8 8 8 8 8 8 2 0 0
或列值为10的另一个示例：
4 4 4 4 4 4 2 0 0 0 0
4 4 4 4 4 4 2 0 0 0 0
2 2 2 2 2 2 2 0 0 0 0
Colum sums将是：
10 10 10 10 10 10 6 0 0 0 0
到目前为止，我所拥有的是它，但它不起作用：
For i = 0 To UBound(ColArray) - 1
ExpColMaxDays = CalculatingManDays(ExpRows, ColArray(i))
DiffManDays = ExpColMaxDays - MonthlyMax
DevAmount = DiffManDays
For j = 0 To UBound(RowArray)
If DevAmount < 0 Then
Do While DevAmount < 0
cells(RowArray(j), ColArray(i)).Value = cells(RowArray(j), ColArray(i)).Value + 1
cells(RowArray(j), ColArray(i) + 1).Value = cells(RowArray(j), ColArray(i) + 1).Value - 1
DevAmount = DevAmount + 1
Loop
ElseIf DevAmount > 0 Then
Do While DevAmount > 0
cells(RowArray(j), ColArray(i)).Value = cells(RowArray(j), ColArray(i)).Value - 1
cells(RowArray(j), ColArray(i) + 1).Value = cells(RowArray(j), ColArray(i) + 1).Value + 1
DevAmount = DevAmount - 1
Loop
End If
Next j
Next i
答案 0 :(得分：3)
很难回答你的问题。
问题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小时。雇主想要针对每个项目和活动类型记录正确的时间，因此我们必须将实际时间从高峰扩展到低谷，而不会将时间从一个活动类型或项目转移到另一个活动类型或项目。
我用来分散时间的算法如下：
我的代码未执行步骤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