excel vba：matrix值重排
我有可以作为matrix可视化的值：
例：
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 柱总和将是：
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
柱总和将是：
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
柱总和将是：
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
柱总和将是：
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
回答你的问题是很难的。
问题1
ExpColMaxDays = CalculatingManDays(ExpRows, ColArray(i))
什么是CalculatingManDays ExpRows和ExpRows ？
问题2
什么是RowArray和ColArray ？ 这似乎是访问一个单元块非常复杂的方式。 除非我缺less这种方法有一些重要意义，否则以下方法更容易。
For RowCrnt = RowTop To RowBottom For ColCrnt = ColLeft to ColRight ... Cells(RowCrnt, ColCrnt) ...
问题3
如果你真的只是想要在矩形中均匀分布值，我build议：
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
新的部分，以回应问题的重新指定
通过阅读你所有的问题，我想我已经理解你正在尝试的是什么。 如果我的理解是正确的，我也有类似的问题。
我的一位雇主要求我们logging每个项目每种活动types所花费的时间。 有高峰期（因为我们在晚上和周末工作，以满足期限）和低谷（因为我们无法进行我们的任何项目），但我们进入我们的时间表所需的电子系统要求我们每周工作不超过37.5小时。 雇主希望对每个项目和活动typeslogging正确的时间，所以我们必须将实际的时间从峰到谷分配，而不必将时间从一个活动types或项目移到另一个活动types或项目。
我用来分散时间的algorithm如下：
- 如果这段时间的总时间不是所需的37.5倍，那么时间从最高峰或最低谷转移到下一个周期的第一周。
- 主循环的每个周期将select总数最高的一周。 如果总计小于或等于37.5小时，则algorithm结束。
- 每个任务（活动types和项目）logging的时间会减less，所以新的总时间是37.5，每个任务的时间与一周总时间的新比例尽可能与原始比例类似。
- 从每个任务中扣除的时间将在前一周和后一周之间平均分配，除非该周已经正确，在这种情况下，在同一方向下一个未修正的星期收到额外的时间。
我的代码不执行步骤1.如果总时间超过了允许的最大值，问题被拒绝为不可解决的。 步骤2到步骤4的结果不是你的例子的传播，因为时间从一个峰值移动到最近的谷值，并且因为时间不是在一行之间移动。 在这个过程的最后，所有的峰值都被移除了，剩下的谷值可以在这个时间段内的任何地方。 这给出了一个更现实的外观，并显示如果每周最大值没有被超过， 可能如何将时间分配给任务。
为了testing，我已经加载了每个工作表的问题。 单元格A1包含最大列值。 该matrix在单元格B2中开始并继续到第一个空白列和第一个空白行。 如果需要，行1和列A的其余部分可用于标题。 第一个空列右边的列不被检查，可以用于注释。 matrix下方的区域用于答案。
我有一个控制例程，加载数据并调用不知道工作表的重新分配例程。
重新分配例程接受最大列值和matrix作为参数，并在原地更新matrix。
一般来说，我相信给客户他们所要求的。 我可以轻轻推动他们朝我认为他们需要的方向发展，但是他们往往必须先看到第一个版本，然后才能理解为什么我怀疑它可能不是他们所需要的。 在这里，我已经违反了自己的规则，并且给了你我需要的东西。 如果你真的需要一个均匀的分布，这个代码可以很容易地适应创build它，但我希望你看到一个“现实”的分配第一。
我已经在我的代码中放置了注释，但是algorithm的更精细的点可能不清楚。 试着select重新分配问题的代码。 如果它看起来正确，我可以给出进一步的解释和详细的algorithm部分，可能需要微调。
我没有删除我的诊断代码。
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