Add Auto sum in selected blank cells VBA

[Sufiyan97]

I am using below code, I just want to add Auto sum at the end when blank cells are selected

This is how data looks in column I

and after adding a sum if the result is negative (<0) then move sum total to column H and if the sum is positive (>0) then move sum total to column G

Sub SortAndAddBlankRowsAndSelectBlankCellsInColumnI()
    Dim ws As Worksheet
    Dim lastRowJ As Long
    Dim lastRowI As Long
    Dim i As Long
    Dim blankRange As Range
   
    ' Set the worksheet where your data is located
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to your actual sheet name
   
    ' Find the last row in column J
    lastRowJ = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row
   
    ' Sort the range J2 to the last used row
    ws.Range("J2:J" & lastRowJ).Sort key1:=ws.Range("J2"), _
                                      order1:=xlAscending, _
                                      Header:=xlNo
   
    ' Loop through each cell in column J starting from the last row and moving upwards
    For i = lastRowJ To 3 Step -1
        ' Check if the property name changes
        If ws.Cells(i, "J").Value <> ws.Cells(i - 1, "J").Value Then
            ' Insert a blank row below the current row
            ws.Cells(i, "J").EntireRow.Insert
        End If
    Next i
   
    ' Find the last row in column I
    lastRowI = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
   
    ' Define the range of blank cells in column I
    On Error Resume Next
    Set blankRange = ws.Range("I2:I" & lastRowI).SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
   
    ' Select the blank cells in column I
    If Not blankRange Is Nothing Then
        blankRange.Select
    Else
        MsgBox "No blank cells found in column I.", vbInformation
    End If
End Sub

 

[Jeffrey Mahoney]

How about some simple formulas?

Book4
	G	H	I
1		Beginning Balance:	1,245.00
2	Additions to cash	Subtractions from cash	Balance
3		240.00	1,005.00
4		225.00	780.00
5		220.00	560.00
6	125.00	300.00	385.00
7	385.00
8		45.00	340.00
9		1,500.00	-1,160.00
10	612.00		-548.00
11	100.00		-448.00
12	200.00		-248.00
13		-248.00
Sheet2

Cell Formulas
Range	Formula
I3:I6,I8:I12	I3	=IF(ISNUMBER(I2)=FALSE,I1,I2)+G3-H3
G7,G13	G7	=IF(AND(I7="",I6>=0),I6,"")
H7,H13	H7	=IF(AND(I7="",I6<0),I6,"")

 

[igold]

Another approach:

Subtotals1.xlsm
	E	F	G	H	I	J	K
1				Subtractions from cash	Balance
2				240.00	240.00
3				225.00	225.00
4				220.00	220.00
5				300.00	300.00
6			985
7				45.00	45.00
8				225.00	225.00
9				1143.75	1143.75
10				1087.50	1087.50
11				1012.50	1012.50
12				900.00	900.00
13			4413.75
14				975.00	975.00
15				975.00	975.00
16				956.25	956.25
17				120.28	120.28
18			3026.53
19
Sheet1

Sub GetSubs2()

    Application.ScreenUpdating = False
    Dim subt As Double
    Dim TopofSection As Long, lastrow As Long

    lastrow = Cells(Rows.Count, "I").End(xlUp).Row
    Do Until lastrow < 2
        TopofSection = Cells(lastrow, "I").End(xlUp).Row
        If Cells(lastrow - 1, 9) = "" Then TopofSection = lastrow
        subt = WorksheetFunction.Sum(Range("I" & TopofSection, "I" & lastrow))
        If subt < 0 Then
            Range("H" & lastrow).Offset(1, 0).Value = subt
        End If
        If subt > 0 Then
            Range("G" & lastrow).Offset(1, 0).Value = subt
        End If
        lastrow = Cells(TopofSection, 9).End(xlUp).Row
    Loop
    Application.ScreenUpdating = True
    
End Sub

 

[Sufiyan97]

How about some simple formulas?

Book4
	G	H	I
1		Beginning Balance:	1,245.00
2	Additions to cash	Subtractions from cash	Balance
3		240.00	1,005.00
4		225.00	780.00
5		220.00	560.00
6	125.00	300.00	385.00
7	385.00
8		45.00	340.00
9		1,500.00	-1,160.00
10	612.00		-548.00
11	100.00		-448.00
12	200.00		-248.00
13		-248.00
Sheet2

Cell Formulas
Range	Formula
I3:I6,I8:I12	I3	=IF(ISNUMBER(I2)=FALSE,I1,I2)+G3-H3
G7,G13	G7	=IF(AND(I7="",I6>=0),I6,"")
H7,H13	H7	=IF(AND(I7="",I6<0),I6,"")

Thanks for the solution but I want a VBA solution.

 

[Sufiyan97]

Another approach:

Subtotals1.xlsm
	E	F	G	H	I	J	K
1				Subtractions from cash	Balance
2				240.00	240.00
3				225.00	225.00
4				220.00	220.00
5				300.00	300.00
6			985
7				45.00	45.00
8				225.00	225.00
9				1143.75	1143.75
10				1087.50	1087.50
11				1012.50	1012.50
12				900.00	900.00
13			4413.75
14				975.00	975.00
15				975.00	975.00
16				956.25	956.25
17				120.28	120.28
18			3026.53
19
Sheet1

Sub GetSubs2()

    Application.ScreenUpdating = False
    Dim subt As Double
    Dim TopofSection As Long, lastrow As Long

    lastrow = Cells(Rows.Count, "I").End(xlUp).Row
    Do Until lastrow < 2
        TopofSection = Cells(lastrow, "I").End(xlUp).Row
        If Cells(lastrow - 1, 9) = "" Then TopofSection = lastrow
        subt = WorksheetFunction.Sum(Range("I" & TopofSection, "I" & lastrow))
        If subt < 0 Then
            Range("H" & lastrow).Offset(1, 0).Value = subt
        End If
        If subt > 0 Then
            Range("G" & lastrow).Offset(1, 0).Value = subt
        End If
        lastrow = Cells(TopofSection, 9).End(xlUp).Row
    Loop
    Application.ScreenUpdating = True
   
End Sub

Thank you very much, I want just a single code combined, this and the one I posted.