Function Matrix(aTotalRows As Variant, aTotalCols As Variant, dBase As Double, Optional ByVal lAdjTimes As Long = 100) As Variant
Dim aResult As Variant
Dim i As Long, j As Long, i1 As Long, i2 As Long, j1 As Long, j2 As Long, dMin As Double, dAdj As Double
aTotalRows = aTotalRows
aTotalCols = aTotalCols
ReDim aResult(1 To UBound(aTotalRows, 1), 1 To UBound(aTotalCols, 2))
For i = 1 To UBound(aResult, 1)
For j = 1 To UBound(aResult, 2)
aResult(i, j) = Application.Min(aTotalRows(i, 1), aTotalCols(1, j))
aTotalRows(i, 1) = aTotalRows(i, 1) - aResult(i, j)
aTotalCols(1, j) = aTotalCols(1, j) - aResult(i, j)
Next
Next
Randomize
If aTotalRows(UBound(aTotalRows, 1), 1) <> 0 Or aTotalCols(1, UBound(aTotalCols, 2)) <> 0 Then
Matrix = CVErr(xlErrNA)
Else
For i = 1 To lAdjTimes
GetRnd aResult, i1, j1
GetRnd aResult, i2, j2
dMin = Application.Min(aResult(i1, j1), aResult(i2, j2))
dAdj = Round((Int(Rnd() * Round(dMin / dBase, 0)) + 1) * dBase, 6)
If dAdj < 0 Then Debug.Print dAdj
aResult(i1, j1) = Round(aResult(i1, j1) - dAdj, 6)
aResult(i1, j2) = Round(aResult(i1, j2) + dAdj, 6)
aResult(i2, j2) = Round(aResult(i2, j2) - dAdj, 6)
aResult(i2, j1) = Round(aResult(i2, j1) + dAdj, 6)
Next
Matrix = aResult
End If
End Function
Private Sub GetRnd(ByRef aResult As Variant, ByRef i As Long, ByRef j As Long)
Dim k As Long
Do
i = Int(Rnd() * UBound(aResult, 1)) + 1
j = Int(Rnd() * UBound(aResult, 2)) + 1
k = k + 1
Loop Until aResult(i, j) > 0 Or k > 1000
End Sub
