Excel VBA中：矩阵值重排

实施例：

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例如在每一列填充它从左边开始什么是t他最好的方式来分配行中的数字？最后，我需要这样的：

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

来源

2012-01-20 user366121

可能重复的[Excel VBA中：天的分布（http://stackoverflow.com/questions/8816399/excel-vba-distribution-of-days） – brettdj

如果总和等于'N'然后在每个单元格中放置值N/33 ...如果你想要一个不同的答案，那么你必须以不同的方式来表达你的问题（即更清楚）。 –

@ Jean-Francois Corbett：我用更多的例子扩展了这个问题。我希望现在更清楚。 – user366121

很难回答你的问题。

问题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

响应的问题

respecification新科

通过阅读你所有的问题，我想我有一个了解你正在尝试的东西。如果我的理解是正确的，我也有类似的问题。

我的一位雇主要求我们记录每个项目每种活动类型花费的时间。有高峰（因为我们在晚上和周末工作以满足期限）和低谷（因为我们无法推进我们的任何项目），但我们进入时间表的电子系统要求我们每周工作时间不超过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

来源

2012-01-20 15:48:04

嗨我使用了代码thx中的变体。也许这个例子被严重挑选，给人的印象是总和必须平均分配。但它应该基于为每列定义的值进行分配。因此，如果值为8或10，那么应该重新排列这些值，根据零值留下右边。 – user366121

我没有找到任何帮助的新例子。这部分是因为你在照片前不给予，部分原因是你还没有解释所需的分配。在第一个示例中，您已在整个矩阵中均匀地重新分配。在第二部分中，您已经从左上角开始重新分配，值为3或4.为什么是3或4？在价值区域的右侧和底部放置较低价值的标准是什么？为什么这个更低的值2？ “CalculatingManDays”功能有什么作用？ “ExpColMaxDays”和“ExpRows”的值是多少？ –

我添加了上面的解释。 – user366121

Excel VBA中：矩阵值重排

回答

相关问题