VBA Code to auto sum data

[MHamid]

Hello,

I have a count in column Q. After I insert a blank row, I would like to do a find for the blank cells in column Q and do a sum of the data above each blank cell.

For instance, each section is divided by each different fruits. Where the Total row is, that is where the total sum will be.
Column J Column Q
Apple 1
Apple 1
Apple 1
Apple 1
Apple 1
Apple Total 5
Banana 1
Banana 1
Banana 1
Banana Total 3
Cherry 1
Cherry 1
Cherry Total 2

Is this possible to do with vba code?

Thank you

 

[Fluff]

How about

Sub AddSum()
   Dim rng As Range
   For Each rng In Range("Q:Q").SpecialCells(xlConstants).Areas
      rng.Offset(rng.Count).Resize(1, 1).Formula = "=sum(" & rng.Address & ")"
   Next rng
End Sub

 

[MHamid]

Hello,

This worked perfectly.

Is there a way to get a Grand Total of all the Total items using VBA Code?

Column J Column Q
Apple 1
Apple 1
Apple 1
Apple 1
Apple 1
Apple Total 5
Banana 1
Banana 1
Banana 1
Banana Total 3
Cherry 1
Cherry 1
Cherry Total 2
Grand Total 10


Thank you

 

[Fluff]

How about

Sub AddSum()
   Dim rng As Range
   For Each rng In Range("Q:Q").SpecialCells(xlConstants).Areas
      rng.Offset(rng.Count).Resize(1, 1).Formula = "=sum(" & rng.Address & ")"
   Next rng
   Range("Q" & Rows.Count).End(xlUp).Offset(1).Formula = "=sum(" & Range("P:P").SpecialCells(xlBlanks).Offset(, 1).Address & ")"
End Sub

 

[MHamid]

Hello,

I just tested your code and it's not giving me the Grand Total.
The Grand Total is 0 instead of the 10.
It looks like the formula for the Grand Total is including the cell where the Grand Total should be and some cells afterwards where there is no data.

Thank you

 

[Fluff]

That sounds like the Used area is extending below the actual data.
Select all rows from the end of the data (including the last total row & the grand total row) to the bottom of the sheet & delete them, then save the workbook & try the code again

 

[MHamid]

Hello,

I did what you suggested and it works.
is it possible to add coding to bold the total count after it sums it up?

Thank you

 

[MHamid]

Hello,

I actually figured it out.
I've added the below in red to your code. Let me know if this is how you would have done it.

'Adding Totals
   Dim rng As Range
   For Each rng In Range("Q:Q").SpecialCells(xlConstants).Areas
      rng.Offset(rng.Count).Resize(1, 1).Formula = "=sum(" & rng.Address & ")"
      rng[COLOR=#FF0000].Offset(rng.Count).Resize(1, 1).Font.Bold = True[/COLOR]
   Next rng
   Range("Q" & Rows.Count).End(xlUp).Offset(1).Formula = "=sum(" & Range("P:P").SpecialCells(xlBlanks).Offset(, 1).Address & ")"
End Sub

Thank you

 

[Fluff]

Yup that's fine

 

[MHamid]

Thanks.

So I just added this code to my full code and the grand total is showing as 0 again. This time the grand total formula goes up to the cell where the formula is at. Anyway we can get around this issue?
Also, let me know if there is a way to condense the code.

Sub RunAll()
    Call CopyTech
    Call FormattingTech
End Sub
Sub CopyTech()
Dim findrow As Long, findrow2 As Long
    
Worksheets("Sheet1").Activate
On Error GoTo errhandler
findrow = Range("L:L").Find("Technology", Range("L1")).Row
findrow2 = Range("L:L").Find("L1_Area", Range("L" & findrow)).Row
Range("B" & findrow & ":P" & findrow2 - 1).Copy
'Range("B" & findrow & ":P" & findrow2).Copy
Worksheets("Sheet5").Activate
Worksheets("Sheet5").Range("J2").PasteSpecial paste:=xlPasteValuesAndNumberFormats
    With Selection.Font
        .Name = "Arial"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
Application.CutCopyMode = False
Exit Sub
errhandler:
    MsgBox "No Cells containing specified text found"
End Sub
Sub FormattingTech()
    
Worksheets("Sheet5").Activate
'Moving columns
    Columns("S:S").Select
    Selection.Cut
    Columns("J:J").Select
    Selection.Insert shift:=xlToRight
    Columns("R:R").Select
    Selection.Cut
    Columns("M:M").Select
    Selection.Insert shift:=xlToRight
    Columns("R:R").Select
    Selection.Cut
    Columns("O:O").Select
    Selection.Insert shift:=xlToRight
    
'Delete columns
    Range("P:Q,S:U,W:X").Delete shift:=xlToLeft
    
'Sort Business
    Range("J1").Select
    ActiveWorkbook.Worksheets("Sheet5").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet5").Sort.SortFields.Add Key:=Range("J2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet5").Sort
        .SetRange Range("J2:Q100")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Columns("J:J").EntireColumn.autofit
    
'Remove "Technology" from Business Names
    Columns("J:J").Select
    Selection.Replace What:="GCB Technology", Replacement:="GCB Tech", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="ICG Technology", Replacement:="ICG", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
'Header Creation and Formatting
    Range("J1").FormulaR1C1 = "Business"
    Range("K1").FormulaR1C1 = "Audit Name"
    Range("L1").FormulaR1C1 = "Audit Type"
    Range("M1").FormulaR1C1 = "2018 Control Rating"
    Range("N1").FormulaR1C1 = "Planning Start Date"
    Range("O1").FormulaR1C1 = "Report Publication Date"
    Range("P1").FormulaR1C1 = "Review Status"
    Range("Q1").FormulaR1C1 = "2Q 2018"
    
    Range("J1:Q1").Select
        With Selection
            .Interior.Pattern = xlSolid
            .Interior.PatternColorIndex = xlAutomatic
            .Interior.ThemeColor = xlThemeColorDark1
            .Interior.TintAndShade = -0.149998474074526
            .Interior.PatternTintAndShade = 0
            .Font.Name = "Arial"
            .Font.Size = 8
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .WrapText = True
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
        End With
    Range("J1").Select
'Aligning Columns
    Columns("L:Q").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("J2").Select
'Add Border
Dim lastRow As Long
lastRow = Cells(Rows.Count, "J").End(xlUp).Offset(1).Row
Call SetRangeBorder(Range("J1:Q" & lastRow))
   
'Adding footer for each section and grand total
   Dim lr As Long
   Dim X As Long
   
   lr = Range("J" & Rows.Count).End(xlUp).Row
   Application.ScreenUpdating = False
   For X = lr + 1 To 3 Step -1
      If Cells(X, 10).Value <> Cells(X - 1, 10) Then
         Rows(X).Insert
         With Range("J" & X)
            .Value = .Offset(-1).Value & " Total"
            .Font.Bold = True
            .Resize(, 7).Borders.LineStyle = xlNone
            .Resize(, 7).BorderAround xlContinuous, xlThin
            .Resize(, 8).Interior.Color = 15849925
         End With
      End If
   Next X
    With Range("J" & Cells(Rows.Count, "J").End(xlUp).Row + 1)
        .Value = "Grand Total"
                .Resize(, 8).Interior.Color = 14857357
                .Resize(, 7).Borders.LineStyle = xlNone
                .Resize(, 7).BorderAround xlContinuous, xlThin
                .Resize(, 8).Font.Bold = True
                .Resize(, 8).Font.Name = "Arial"
                .Resize(, 8).Font.Size = 8
    End With
   Application.ScreenUpdating = True
'Adding Totals
   Dim rng As Range
   For Each rng In Range("Q:Q").SpecialCells(xlConstants).Areas
      rng.Offset(rng.Count).Resize(1, 1).Formula = "=sum(" & rng.Address & ")"
      rng.Offset(rng.Count).Resize(1, 1).Font.Bold = True
   Next rng
   Range("Q" & Rows.Count).End(xlUp).Offset(1).Formula = "=sum(" & Range("P:P").SpecialCells(xlBlanks).Offset(, 1).Address & ")"
End Sub
Sub SetRangeBorder(poRng As Range)
    If Not poRng Is Nothing Then
        poRng.Borders(xlDiagonalDown).LineStyle = xlNone
        poRng.Borders(xlDiagonalUp).LineStyle = xlNone
        poRng.Borders(xlEdgeLeft).LineStyle = xlContinuous
        poRng.Borders(xlEdgeTop).LineStyle = xlContinuous
        poRng.Borders(xlEdgeBottom).LineStyle = xlContinuous
        poRng.Borders(xlEdgeRight).LineStyle = xlContinuous
        poRng.Borders(xlInsideVertical).LineStyle = xlContinuous
        poRng.Borders(xlInsideHorizontal).LineStyle = xlContinuous
    End If
End Sub

Thank you