Sum Cell Values Until Blank Cells With VBA

[blueman0110]

https://i.stack.imgur.com/D5SwL.pngI found this code on the internet. How do I get the sum value to appear in the empty cell above the cells containing consecutive values. I'm thinking of running the code from the last row. Thank for your help :yes


https://www.extendoffice.com/documents/excel/3963-excel-sum-until-blank.html


Sub InsertTotals()
'Updateby Extendoffice
Dim xRg As Range
Dim i, j, StartRow, StartCol As Integer
Dim xTxt As String
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.AddressLocal
Set xRg = Application.InputBox("please select the cells:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
StartRow = xRg.Row
StartCol = xRg.Column
For i = StartCol To xRg.Columns.Count + StartCol - 1
For j = xRg.Row To xRg.Rows.Count + StartRow - 1
If Cells(j, i) = "" Then
Cells(j, i).Formula = "=SUM(" & Cells(StartRow, i).Address & ":" & Cells(j - 1, i).Address & ")"
StartRow = j + 1
End If
Next
StartRow = xRg.Row
Next
End Sub

[mancubus]

welcome to the forum

try this:



Sub vbax_69213_Sum_Cell_Values_Until_Blank_Cells()

Dim LastRow As Long, CounterRow As Long, BottomRow As Long

LastRow = Range("A" & Rows.Count).End(xlUp).Row 'assuming numbers to sum and blank sum cells are in col A
BottomRow = LastRow

For CounterRow = LastRow To 3 Step -1 'assuming first blank sum cell is A3
If Range("A" & CounterRow) = "" Then
Range("A" & CounterRow) = Application.Sum(Range("A" & CounterRow + 1, "A" & BottomRow))
BottomRow = CounterRow - 1
End If
Next CounterRow

End Sub

[mancubus]

sum cells are formatted:



Sub vbax_69213_sum_cells_until_blank_cells_above()

Dim LastRow As Long, CounterRow As Long, BottomRow As Long

LastRow = Range("A" & Rows.Count).End(xlUp).Row 'assuming numbers to sum and blank sum cells are in col A
BottomRow = LastRow

For CounterRow = LastRow To 3 Step -1 'assuming first blank sum cell is A3 and first number cell is A4
If Range("A" & CounterRow) = "" Then
Range("A" & CounterRow) = Application.Sum(Range("A" & CounterRow + 1, "A" & BottomRow))
Range("A" & CounterRow).Font.Bold = True
Range("A" & CounterRow).Interior.Color = vbYellow
BottomRow = CounterRow - 1
End If
Next CounterRow

End Sub

[mancubus]

in case you need to insert sums below numbers use;



Sub vbax_69213_sum_cells_until_blank_cells_below()

Dim LastRow As Long, CounterRow As Long, TopRow As Long

LastRow = Range("A" & Rows.Count).End(xlUp).Row 'assuming numbers to sum and blank sum cells are in col A
TopRow = 3

For CounterRow = TopRow To LastRow + 1 'assuming first number cell is A3
If Range("A" & CounterRow) = "" Then
Range("A" & CounterRow) = Application.Sum(Range("A" & TopRow, "A" & CounterRow - 1))
Range("A" & CounterRow).Font.Bold = True
Range("A" & CounterRow).Interior.Color = vbYellow
TopRow = CounterRow + 1
End If
Next CounterRow

End Sub

[blueman0110]

welcome to the forum

try this:



Sub vbax_69213_Sum_Cell_Values_Until_Blank_Cells()

Dim LastRow As Long, CounterRow As Long, BottomRow As Long

LastRow = Range("A" & Rows.Count).End(xlUp).Row 'assuming numbers to sum and blank sum cells are in col A
BottomRow = LastRow

For CounterRow = LastRow To 3 Step -1 'assuming first blank sum cell is A3
If Range("A" & CounterRow) = "" Then
Range("A" & CounterRow) = Application.Sum(Range("A" & CounterRow + 1, "A" & BottomRow))
BottomRow = CounterRow - 1
End If
Next CounterRow

End Sub

Great, it works great. But at cell blank there is no sum function. I can't distinguish the original value. You are No.1

[mancubus]

see post #3