excel vba: matrix value rearrangement - excel

Question

I have values which could be visualized as a matrix:
Example:
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 would be:
23 16 5 11 11 0 0 0 0 0 0
Total sum would be: 66
If the sums should be 6 for example in each column filling it up starting from the left side what would be the best way to distribute the numbers in the rows? In the end I would need something like this:
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 would be:
6 6 6 6 6 6 6 6 6 6 6
Total sum would be: 66
Another example where the sum in the columns does not indicate even distribution:
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 would be:
8 8 8 8 8 8 8 8 2 0 0
Or another example with column value of 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 would be:
10 10 10 10 10 10 6 0 0 0 0
What I have so far is this but it is not working:
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

It is difficult to answer your question.
Problem 1
ExpColMaxDays = CalculatingManDays(ExpRows, ColArray(i))
What are CalculatingManDays and ExpRows?
Problem 2
What are RowArray and ColArray? This seems a very complicated way of accessing a block of cells. The following is easier unless there is some significance to this approach I am missing.
For RowCrnt = RowTop To RowBottom
For ColCrnt = ColLeft to ColRight
... Cells(RowCrnt, ColCrnt) ...
Problem 3
If you really just want to distribute the values evenly across the rectangle, I suggest:
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
New section in response to respecification of problem
By reading all your questions, I think I have an understanding of what you are attempting. If my understanding is correct, I have had a similar problem.
One of my employers required us to keep records of the time spent on each activity type per project. There were peaks (because we worked evenings and weekends to meet deadlines) and troughs (because we could not progress any of our projects) but the electronic system into which we entered our timesheets required we work not more than 37.5 hours per week. The employer wanted the correct time recorded against each project and activity type so we had to spread the actual time out from peaks to troughs without moving time from one activity type or project to another.
The algorithm I used to spread out my time was as follows:
If the total time for the period was not the required multiple of 37.5, time was moved from the highest peaks or the deepest troughs to the first week of the next period.
Each cycle of the main loop would pick the week with the highest total. If this total was less than or equal to 37.5 hours, the algorithm was finished.
The time recorded against each task (activity type and project) would be reduced so the new total was 37.5 and the new proportion of each task’s time to the total time for the week was as similar to the original proportion as possible.
The time subtracted from each task would be divided equally between the week before and the week after unless that week had already been correctly in which case the next uncorrected week in the same direction received the extra time.
My code does not perform step 1. If the total time exceeds the permitted maximum, the problem is rejected as unsolvable. The result of steps 2 to 4 is not the even spread of your examples because time is moved from a peak to the nearest trough and because time is not moved from row to row. At the end of the process, all peaks have been removed and any remaining troughs can be anywhere within the period. This gives a more realistic appearance and shows how time might have been allocated to tasks if the weekly maximum had not been exceeded.
For testing I have loaded each worksheet with a problem. Cell A1 contains the maximum column value. The matrix starts in cell B2 and continues to the first blank column and the first blank row. The remainder of row 1 and column A may be used for headings if desired. Columns to the right of the first blank column are not examined and may be used for comments. The area below the matrix is used for the answer.
I have a control routine which loads data and calls the redistribution routine which does not know about the worksheets.
The redistribution routine accepts the maximum column value and the matrix as parameters and updates the matrix in situ.
In general I believe in giving the client what they have asked for. I may gently push them in the direction of what I think they need but too often they must see the first version before they can understand why I suspect it may not be what they need. Here I have broken my own rule and have given you what I think you need. If you really do need an even distribution, this code can easily be adapted to create it but I want you to see a “realistic” distribution first.
I have placed comments within my code but the finer points of the algorithm may not be clear. Try the code on a selection of redistribution problems. If it looks about right I can give further explanations and detail parts of the algorithm that may require fine tuning.
I have not removed my diagnostic code.
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