岩溶水用水量包不住調配代碼

'算法
'第一步：將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