エクセルVBA：マトリックス値転位

Question

Iのマトリックスとして視覚化することができる値を有する：

例：

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合計は次のようになります。

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 

Colum和は次のようになります。

は

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の合計は次のようになります。

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和は次のようになります。

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 

Answer 1

あなたの質問に答えるのは難しいです。

問題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

あなたは本当にただの長方形に均等に値を配布したい場合は、私がお勧め：問題

のrespecificationに応じて

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つの活動タイプまたはプロジェクトから別のアクティビティタイプまたはプロジェクトに時間を移動することなく、実際のタイムアウトをピークから谷まで広げなければなりませんでした。次のように

私は私の時間を分散するために使用されるアルゴリズムをした

1. 期間の合計時間は、37.5の必要な複数でなかった場合は、時間は最高のピークまたは最も深い谷から移動されました次の期間の最初の週。
2. メインループの各サイクルで合計が最も高い週が選択されます。この合計が37.5時間以下の場合、アルゴリズムは終了しました。
3. 各タスク（アクティビティタイプとプロジェクト）に対して記録された時間が短縮され、新しい合計が37.5になり、週の合計時間に対する各タスクの時間の新しい割合が可能な限り元の割合に似ていました。
4. 各タスクから差し引かれた時間は、その週がすでに正しくなっていない限り、前の週と後の週との間で等しく分割され、同じ方向の次の補正されていない週が余分な時間を受け取った。

私のコードはステップ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