excel vba adding and subtracting values in different cells

问题

I am working on a kind of scheduling sheet in Excel. In this sheet man days for certain experts and activities are entered. It often occurs that man days have to be shifted between experts and activities. The part I am stuck with is the actual updating of values in the cells. The idea is that all the lines in my first array represent row numbers. I step through each cell in the range look for a value and subtract the shifting days. If the shifting days are greater than the cell value I move to the next and so on until all days are spent. The second routine uses the same system but increases the man days. My problem is that the man days for the source activity are increased and then decreased but the target activity should be increased and the source activity decreased.

Structure of the sheet to get the idea - the part in brackets should be updated:

     M1 M2 M3 ... EXP1 EXP2 EXP3
A1[  1  1  1  ]    3 
A2[  1     1  ]         2
A3[        1  ]              1

Code to reduce man days:

ReduceDaysCounter = ShiftDays

For row = UBound(FirstExpRowNumbers) To 0 Step -1  
    If FirstExpRowNumbers(row) > 0 And FirstExpRowNumbers(row) <= LastRow() Then
        For col = ExpertColumns(0) - 1 To 5 Step -1
            CurrCellValue = cells(FirstExpRowNumbers(row), col).Value
            If CurrCellValue > 0 And ReduceDaysCounter > 0 Then
                If ReduceDaysCounter >= CurrCellValue Then
                    cells(FirstExpRowNumbers(row), col).Value = 0
                    ReduceDaysCounter = ReduceDaysCounter - CurrCellValue
                End If
            End If
        Next
    End If
Next

Code to increase man days:

IncreaseDaysCounter = ShiftDays

For row = 0 To UBound(SecondExpRowNumbers)  
    If SecondExpRowNumbers(row) > 0 And SecondExpRowNumbers(row) <= LastRow() Then
        For col = 5 To ExpertColumns(0) - 1
            CurrCellValue = cells(SecondExpRowNumbers(row), col).Value
            If CurrCellValue > 0 And IncreaseDaysCounter > 0 Then
                'If CurrCellValue < 2 Then
                    cells(SecondExpRowNumbers(row), col).Value = CurrCellValue + 1
                    IncreaseDaysCounter = IncreaseDaysCounter - 1
                'End If
            End If
        Next
    End If
Next

回答1:

Ok I found the problem. This is the function to find the correct rownumber:

Function FindingSDExpRow(actrow, expname)

Dim SDExpRow As Integer
SDExpRow = 0

Do While SDExpRow = 0
    actrow = actrow + 1
    If Left((cells(actrow, 2).Value), Len(expname)) = expname Then
        SDExpRow = cells(actrow, 2).row
    End If
Loop

FindingSDExpRow = SDExpRow

End Function

And then it is rather easy - modified code for updating cell values:

ReduceDaysCounter = ShiftDays

For col = ExpertColumns(0) - 1 To 5 Step -1
    CurrCellValue = cells(FirstExpRow, col).Value
    If CurrCellValue > 0 And ReduceDaysCounter > 0 Then
        If ReduceDaysCounter >= CurrCellValue Then
            cells(FirstExpRow, col).Value = 0
            ReduceDaysCounter = ReduceDaysCounter - CurrCellValue
        End If
    End If
Next

IncreaseDaysCounter = ShiftDays

For col = 5 To ExpertColumns(0) - 1
    CurrCellValue = cells(SeconExpRow, col).Value
    If CurrCellValue > 0 And IncreaseDaysCounter > 0 Then
        cells(SeconExpRow, col).Value = CurrCellValue + 1
        IncreaseDaysCounter = IncreaseDaysCounter - 1
    End If
Next

来源：https://stackoverflow.com/questions/8476979/excel-vba-adding-and-subtracting-values-in-different-cells