限行列和随机加墙版_递归调用解决结果含负数问题

Sub 限行列和随机加墙版()
    Dim nRows As Long, nCols As Long, nLastRow As Long, tmpSum As Long, tmpRow As Long, r As Long, c As Long
    Dim sumRows() As Long, nRowSkipSum() As Long, nColSkipSum() As Long, nColsLast() As Long
    Dim bForceValue() As Boolean
    Dim vArr() As Variant
    Dim fOffset As Single
    vArr = Sheet1.Range("A2").CurrentRegion.Value '取数据
    nRows = UBound(vArr)
    nCols = UBound(vArr, 2)
    ReDim sumRows(3 To nRows)
    ReDim nRowSkipSum(3 To nRows)
    ReDim nColsLast(3 To nRows)
    ReDim nColSkipSum(2 To nCols - 1)
    ReDim nRowsLast(2 To nCols - 1)
    ReDim bForceValue(3 To nRows, 2 To nCols)
    With Sheet1.Range("A1")
        For c = 2 To nCols - 1
            For r = 3 To nRows
                If .Offset(r - 1, c - 1).Interior.Color = vbYellow Then '背景颜色为黄色的单元格固定原值不变(跳过)
                    bForceValue(r, c) = True
                    bForceValue(r, nCols) = True
                    nRowSkipSum(r) = nRowSkipSum(r) + vArr(r, c) '每行跳过值之和
                    nColSkipSum(c) = nColSkipSum(c) + vArr(r, c) '每列跳过值之和
                Else
                    sumRows(r) = sumRows(r) + vArr(2, c) '每行限制之和
                    If vArr(2, c) <> 0 Then nColsLast(r) = c '每行最后1个列限制和非0的非固定值的列号
                End If
            Next
        Next
    End With
    For c = 2 To nCols - 1
        tmpSum = tmpSum + vArr(2, c)
    Next
    For r = 3 To nRows
        tmpRow = tmpRow + vArr(r, nCols)
        If vArr(r, nCols) <> 0 And bForceValue(r, nCols) = False Then nLastRow = r
    Next
    If tmpRow <> tmpSum Then MsgBox "行与列限制之和不相等！": Exit Sub
    If nLastRow < 3 Then MsgBox "至少要有一行无任何固定值！": Exit Sub
    '        fOffset = 0.05! '随机值浮动百分比
    fOffset = 0.08! '随机值浮动百分比
    '    fOffset = 0.015! '随机值浮动百分比
    Randomize
    For r = 3 To nRows
        If r <> nLastRow Then
            tmpSum = 0
            tmpRow = vArr(r, nCols) - nRowSkipSum(r) '该行剩余可随机值之和
            For c = 2 To nCols - 1
                If c <> nColsLast(r) And bForceValue(r, c) = False Then
                    vArr(r, c) = Int(tmpRow / sumRows(r) * vArr(2, c) * (1! + Rnd * fOffset * 2 - fOffset))
                    tmpSum = tmpSum + vArr(r, c)
                End If
            Next
            vArr(r, nColsLast(r)) = tmpRow - tmpSum '该行剩余列的值
        End If
    Next
    For c = 2 To nCols - 1
        tmpSum = 0
        For r = 3 To nRows
            If r <> nLastRow And bForceValue(r, c) = False Then tmpSum = tmpSum + vArr(r, c)
        Next
        vArr(nLastRow, c) = vArr(2, c) - nColSkipSum(c) - tmpSum '剩余列的剩余值
    Next
    If 二维数组含负数(vArr) = False Then
        Call 限行列和随机加墙版
    Else
        Sheet1.Range("A1").Resize(UBound(vArr), UBound(vArr, 2)).Value = vArr
    End If
End Sub

Function 二维数组含负数(ar)
    flag = True
    For x = 3 To UBound(ar)
        For y = 2 To UBound(ar, 2)
            If ar(x, y) < 0 Then
                flag = False
            End If
        Next
    Next
    二维数组含负数 = flag
End Function


Function 检查二维数组是否合法(vArr)
    '    vArr = Sheet2.Range("A2").CurrentRegion.Value '取数据
    If 二维数组含负数(vArr) = False Then
        MsgBox "随机数不合理,请重试一次!"
    Else
        MsgBox "随机数取值合理,请运行主程序!"
    End If
End Function

Sub 单独检查二维数组是否包含负数()
    vArr = Sheet1.Range("A2").CurrentRegion.Value '取数据
    If 二维数组含负数(vArr) = False Then
        MsgBox "随机数不合理,请重试一次!"
    End If
End Sub