• Status: Solved
• Priority: Medium
• Security: Public
• Views: 316

# Running Total in Single Cell for multiple columns

I have this macro which works great but how do I get it to repeat for each row.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Range("c3").Select
Range("d3").Select
Range("e3").Select
Range("f3").Select
Dim cel As Range, targC As Range, tarD As Range, targE As Range, targF As Range
Set targC = Intersect(Range("h3"), Target)
Set targD = Intersect(Range("i3"), Target)
Set targE = Intersect(Range("j3"), Target)
Set targF = Intersect(Range("k3"), Target)
On Error Resume Next
Application.ScreenUpdating = False

If Not targC Is Nothing Then
For Each cel In targC
Range("c3") = Range("c3") + Range("h3")
'Cells(cel.Row, 8) = Cells(cel.Row, 8) + cel 'Increment total in column H, same row

Next
End If
If Not targD Is Nothing Then
For Each cel In targD
Range("d3") = Range("d3") + Range("i3")
'Cells(cel.Row, 9) = Cells(cel.Row, 9) + cel 'Increment total in column I, same row
Next
End If
If Not targE Is Nothing Then
For Each cel In targE
Range("e3") = Range("e3") + Range("j3")
'Cells(cel.Row, 10) = Cells(cel.Row, 10) + cel 'Increment total in column J, same row
Next
End If
If Not targF Is Nothing Then
For Each cel In targF
Range("f3") = Range("f3") + Range("k3")
'Cells(cel.Row, 11) = Cells(cel.Row, 11) + cel 'Increment total in column K, same row
Next
End If

End Sub
0
• 2
1 Solution

Solutions ConsultantCommented:
I am not sure what you are after?

Could please post a sample workbook so we can see the macro in action and what you would like achieve

Michael
0

Commented:

Whenever a value in columns H/I/J/K is changed then it's added to the value in the same row in columns C/D/E/F. (Apologies if I haven't understood your requirements.)

The code is...
``````Option Explicit

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim cel As Range, targC As Range, targD As Range, targE As Range, targF As Range, xTemp As Range

Set xTemp = Intersect(Range("H:K"), Target)
If xTemp Is Nothing Then Exit Sub

Set targC = Intersect(Range("h:H"), Target)
Set targD = Intersect(Range("I:I"), Target)
Set targE = Intersect(Range("J:J"), Target)
Set targF = Intersect(Range("K:K"), Target)

Application.ScreenUpdating = False
On Error Resume Next
Application.EnableEvents = False

If Not targC Is Nothing Then
For Each cel In targC
If cel <> 0 Then Range("C" & cel.Row) = Range("C" & cel.Row) + cel
Next
End If
If Not targD Is Nothing Then
For Each cel In targD
If cel <> 0 Then Range("D" & cel.Row) = Range("D" & cel.Row) + cel
Next
End If
If Not targE Is Nothing Then
For Each cel In targE
If cel <> 0 Then Range("E" & cel.Row) = Range("E" & cel.Row) + cel
Next
End If
If Not targF Is Nothing Then
For Each cel In targF
If cel <> 0 Then Range("F" & cel.Row) = Range("F" & cel.Row) + cel
Next
End If

Application.EnableEvents = True
On Error GoTo 0
Application.ScreenUpdating = True

End Sub
``````
Regards,
Brian.Increment-on-Change.xlsm
0

Commented:

I really didn't expect to get your requirements right first time - however, I keep an eye on "my" questions for a number of weeks after they're closed, so please feel free to post here if you have any issues.

Regards,
Brian.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.