VBA to sum columns in blank cells

[karadeon]

Hello!

I'm trying to sum certain columns and for the sum to be placed inside the blanks while adding a row after the sum. I used a macro to fill in the Deposits column (which is column D) and the Mkt Share column (which is column E). However, I would need it to also sum column "Br" (which is column F), "Pen" (which is column G). And I would need a blank row to appear after the sum row. I'll place my code in here.

Thanks for your help!

Sub Subtotal()
Dim lngLastRow As Long, _
lngFormulaRowStart As Long, _
lngFormulaRowEnd As Long
Dim rngCell As Range

lngLastRow = Cells(Rows.Count, "D").End(x1Up).Row + 1
lngFormulaRowStart = 2
lngFormulaRowEnd = 2

Application.ScreenUpdating = False

For Each rngCell In Range("D2:D" & lngLastRow)

If Len(rngCell.Value) = 0 Then

lngFormulaRowEnd = rngCell.Row - 1

rngCell.Formula = "=SUM(D" & lngFormulaRowStart & ":D" & lngFormulaRowEnd & ")"
rngCell.Offset(0, 1).Formula = "=SUM(E" & lngFormulaRowStart & ":E" & lngFormulaRowEnd & ")"

lngFormulaRowStart = rngCell.Offset(1, 0).Row
lngFormulaRowEnd = rngCell.Offset(1, 0).Row

End If

Next rngCell

Application.ScreenUpdating = True

End Sub

CBSA	Bank	Rank	Deposits	Mkt Shr	Br	Pen	Dep/Br
Aberdeen, SD	Wells Fargo & Company (CA)	1	361,940	24.4%	3	13.0%	120,647
Aberdeen, SD	Dacotah Banks, Inc. (SD)	2	339,165	22.8%	2	8.7%	169,583
Aberdeen, SD	Great Western Bancorp, Inc. (SD)	3	172,814	11.6%	2	8.7%	86,407
Aberdeen, SD	Plains Commerce Bank (SD)	4	157,716	10.6%	1	4.3%	157,716
Aberdeen, SD	U.S. Bancorp (MN)	5	129,930	8.7%	1	4.3%	129,930
Aberdeen, SD	Roscoe Community Bankshares, Inc. (SD)	6	84,414	5.7%	2	8.7%	42,207
Aberdeen, SD	First Bank Shares Corporation (SD)	7	52,950	3.6%	2	8.7%	26,475
Aberdeen, SD	Ipswich Community Bancshares, Inc. (SD)	8	45,064	3.0%	1	4.3%	45,064
Aberdeen, SD	First State Bank of Claremont (SD)	9	35,983	2.4%	3	13.0%	11,994
Aberdeen, SD	Hopkins Financial Corporation (SD)	10	31,701	2.1%	2	8.7%	15,851
Aberdeen, SD	Great Plains Bank Corporation (SD)	11	30,451	2.0%	1	4.3%	30,451
Aberdeen, SD	First National Bank of Frederick (SD)	12	17,819	1.2%	1	4.3%	17,819
Aberdeen, SD	H2H Bancshares, Inc. (SD)	13	15,526	1.0%	1	4.3%	15,526
Aberdeen, SD	Beresford Bancorporation, Inc. (SD)	14	10,506	0.7%	1	4.3%	10,506
			1,485,979	100.0%
Aberdeen, WA	Pacific Financial Corporation (WA)	1	307,474	33.4%	5	21.7%	61,495
Aberdeen, WA	Timberland Bancorp, Inc. (WA)	2	218,234	23.7%	6	26.1%	36,372
Aberdeen, WA	Anchor Bancorp (WA)	3	206,686	22.5%	5	21.7%	41,337
Aberdeen, WA	Umpqua Holdings Corporation (OR)	4	83,564	9.1%	2	8.7%	41,782
Aberdeen, WA	U.S. Bancorp (MN)	5	30,361	3.3%	1	4.3%	30,361
Aberdeen, WA	KeyCorp (OH)	6	27,395	3.0%	1	4.3%	27,395
Aberdeen, WA	JPMorgan Chase & Co. (NY)	7	21,795	2.4%	1	4.3%	21,795
Aberdeen, WA	Cascade Bancorp (OR)	8	15,923	1.7%	1	4.3%	15,923
Aberdeen, WA	Security State Corporation (WA)	9	9,042	1.0%	1	4.3%	9,042
			920,474	100.0%
Abilene, TX	First Financial Bankshares, Inc. (TX)	1	1,219,536	46.0%	13	29.5%	93,810

<colgroup><col width="197" style="width: 148pt; mso-width-source: userset; mso-width-alt: 7204;"> <col width="285" style="width: 214pt; mso-width-source: userset; mso-width-alt: 10422;"> <col width="36" style="width: 27pt; mso-width-source: userset; mso-width-alt: 1316;"> <col width="76" style="width: 57pt; mso-width-source: userset; mso-width-alt: 2779;"> <col width="49" style="width: 37pt; mso-width-source: userset; mso-width-alt: 1792;"> <col width="28" style="width: 21pt; mso-width-source: userset; mso-width-alt: 1024;"> <col width="42" style="width: 32pt; mso-width-source: userset; mso-width-alt: 1536;"> <col width="76" style="width: 57pt; mso-width-source: userset; mso-width-alt: 2779;"> <tbody> </tbody>

 

[igold]

Hi,

I am not 100% sure I know what your requirements are because you are asking for subtotals and you already have some listed. Anyway this code will subtotal columns "F" & "G" and then insert a blank row.

See if it comes close to what you are looking for... Please test on a backup copy of your data.

Sub GetSubs()


' Add Subtotals
    Application.ScreenUpdating = False
    Dim subt As Double, subt2 As Double
    Dim break As Long
    Dim lastrow As Long


    lastrow = Cells(Rows.Count, "F").End(xlUp).Row
    
nxt:
    break = Cells(lastrow, "F").End(xlUp).Row
    If Cells(lastrow - 1, 6) = "" Then break = lastrow
    subt = WorksheetFunction.Sum(Range("F" & break, "F" & lastrow))
    Range("F" & lastrow).Offset(1, 0).Value = subt
    subt2 = WorksheetFunction.Sum(Range("G" & break, "G" & lastrow))
    Range("G" & lastrow).Offset(1, 0).Value = Format(subt2, "Percent")
    Range("F" & lastrow).Offset(1, 0).Offset(1, 0).EntireRow.Insert
    lastrow = Cells(break, 6).End(xlUp).Row
    If lastrow < 2 Then End
    
    GoTo nxt
    Application.ScreenUpdating = True
    
End Sub

I hope this helps!

igold

 

[karadeon]

This was perfect!!!! Thank you so much for your help!!!

Is it possible do delete groups of rows if a certain name doesn't appear in that group? In the picture I pasted in here, it had Aberdeen, SD and Aberdeen WA. Let's say I wanted to keep the groups of cities that has Anchor Bancorp in that city. Anchor Bancorp appears in Aberdeen, WA but doesn't appear in Aberdeen, SD. Is there a way to delete all the lines of Aberdeen, SD because that specific bank isn't in that city?

 

[karadeon]

This was perfect!!!! Thank you so much for your help!!!

Is it possible do delete groups of rows if a certain name doesn't appear in that group? In the picture I pasted in here, it had Aberdeen, SD and Aberdeen WA. Let's say I wanted to keep the groups of cities that has Anchor Bancorp in that city. Anchor Bancorp appears in Aberdeen, WA but doesn't appear in Aberdeen, SD. Is there a way to delete all the lines of Aberdeen, SD because that specific bank isn't in that city?

 

[igold]

Hi karadeon,

Thanks for the feedback, I am glad we got that part working.

I almost forgot... Welcome to MrExcel.

See if this fulfills your new requirement. Please be sure to test on a backup copy of your worksheet, as this code will delete data that you cannot recover.

Sub GetSubs2()


    'Add Subtotals and remove groups
    Dim bf As Boolean
    Dim subt As Double, subt2 As Double
    Dim break As Long, i As Long, lastrow As Long
    
    Application.ScreenUpdating = False
    lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    
nextgrp:
    bf = False
    break = Cells(lastrow, "F").End(xlUp).Row
    If break = 1 Then break = 2
    If Cells(lastrow - 1, 6) = "" Then break = lastrow
    For i = break To lastrow
        If Cells(i, 2) = "Anchor Bancorp (WA)" Then
            bf = True
            Exit For
        End If
    Next
    If Not bf Then Range(Cells(break, 1), Cells(lastrow + 1, 8)).Delete
    lastrow = Cells(break, 6).End(xlUp).Row
    If lastrow < 2 Then GoTo nxtsec
    GoTo nextgrp
    
nxtsec:
    lastrow = Cells(Rows.Count, "F").End(xlUp).Row
    
nxt:
    break = Cells(lastrow, "F").End(xlUp).Row
    subt = WorksheetFunction.Sum(Range("F" & break, "F" & lastrow))
    Range("F" & lastrow).Offset(1, 0).Value = subt
    subt2 = WorksheetFunction.Sum(Range("G" & break, "G" & lastrow))
    Range("G" & lastrow).Offset(1, 0).Value = Format(subt2, "Percent")
    Range("F" & lastrow).Offset(1, 0).Offset(1, 0).EntireRow.Insert
    lastrow = Cells(break, 6).End(xlUp).Row
    If lastrow < 2 Then GoTo CleanUp
    GoTo nxt
    
CleanUp:
    Application.ScreenUpdating = True
    
End Sub

Let me know how it goes...

igold