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

 6  6  6  6  6  6  6  6  6  6  6

8   8   8   8   8   8   8   8   2   0   0

10  10  10  10  10  10  6   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

哥伦布总额为：

23 16  5  11  11  0  0  0  0  0  0

 6  6  6  6  6  6  6  6  6  6  6

8   8   8   8   8   8   8   8   2   0   0

10  10  10  10  10  10  6   0   0   0   0

总数为：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

哥伦布总额为：

23 16  5  11  11  0  0  0  0  0  0

 6  6  6  6  6  6  6  6  6  6  6

8   8   8   8   8   8   8   8   2   0   0

10  10  10  10  10  10  6   0   0   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

哥伦布总额为：

23 16  5  11  11  0  0  0  0  0  0

 6  6  6  6  6  6  6  6  6  6  6

8   8   8   8   8   8   8   8   2   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

i=0到uBond（ColArray）-1的

ExpColMaxDays=计算工作日（ExpRows，ColArray（i））
DiffManDays=ExpColMaxDays-MonthlyMax
DevAmount=DiffManDays
对于j=0到UBound（行数组）
如果DevAmount<0，则
当装载量<0时执行此操作
单元格（行数组（j），列数组（i））。值=单元格（行数组（j），列数组（i））。值+1
单元格（行数组（j），列数组（i）+1）。值=单元格（行数组（j），列数组（i）+1）。值-1
德瓦蒙特=德瓦蒙特+1
环
ElseIf DevAmount>0则
当装载量>0时执行此操作
单元格（行数组（j），列数组（i））。值=单元格（行数组（j），列数组（i））。值-1
单元格（行数组（j），列数组（i）+1）。值=单元格（行数组（j），列数组（i）+1）。值+1
德瓦蒙特=德瓦蒙特-1
环
如果结束
下一个j
接下来我

很难回答您的问题

问题1

ExpColMaxDays = CalculatingManDays(ExpRows, ColArray(i))

什么是

CalculatingManDays

和

ExpRows

问题2

什么是

行数组

和

列数组

？这似乎是访问一块单元格的一种非常复杂的方式。除非我所缺少的这种方法有某种意义，否则下面的内容更容易

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

选项显式
子控制（）
'对于每个工作表
'*验证并确认