岩溶水用水量包不住调配代码

'算法
'第一步：将2-8項的负差值都加到第1項；
'第二步：将第1項的负差值往后分配出去；
'第三步：将差值加回到各项；
Private Sub btnKarstWaterDiffDeal_Click()
    Dim Y As String
    Dim S As Integer
    
    Y = "2013年"    '年份及Sheet页名称
    S = 2           '列号偏移量
    
    For R = 6 To 135
        Call Collect(R, 8, S)
        Call Distribute(R, 1, S)
        Call ReAllocate(Y, R, S)
    Next
    MsgBox (Y + "岩溶水调配完成")
End Sub

' 将2-8項的负差值都加到第1項
' R     行号
' N     列号
' S     列号偏移量
Private Sub Collect(R, N, S)
    Dim D As Double
    
    While N > 1
        D = Cells(R, N + S)
        If D < 0 Then
            Cells(R, 1 + S) = D + Cells(R, 1 + S)
            Cells(R, N + S) = 0
        End If
        N = N - 1
    Wend
End Sub

'将第1項的负值往后分配出去
' R     行号
' N     列号
' S     列号偏移量
Private Sub Distribute(R, N, S)
    Dim D As Double
    
    While N < 8
        D = Cells(R, N + S)
        If D < 0 Then
            Cells(R, N + S + 1) = Cells(R, N + S + 1) + D
            Cells(R, N + S) = 0
        Else
            Exit Sub
        End If
        N = N + 1
    Wend
End Sub


'将差值加回到各项
Private Sub ReAllocate(SheetName, R, S)
    Dim D As Double
    Dim A(7) As Integer
    A(0) = 6    '城镇生活的岩溶水用水量
    A(1) = 13   '农村生活
    A(2) = 24   '第三产业
    A(3) = 20    '建筑业
    A(4) = 2    '工业
    A(5) = 9    '农业灌溉
    A(6) = 16   '林牧渔业
    A(7) = 27   '生态
    
    For i = 0 To 7
        '调整后的差值
        D = Cells(R, i + 1 + S)
        ' 当调整后的差值和原差值不等时，就认为该项岩溶水调整过，这时，才需要将调整后的差值加回去
        If D <> Worksheets(SheetName).Cells(R, A(i) + 1 + S) Then
            '岩溶水 = 用水量 - 新的差值
            Worksheets(SheetName).Cells(R, A(i) + S) = Worksheets(SheetName).Cells(R, A(i) - 1 + S) - D
            '赋回新差值，原表中有计算差值的公式
            'Worksheets(SheetName).Cells(R, A(i) + 1 + S) = D
        End If
    Next
End Sub