Macro Create Sum and Separate Zeroes

[unknownymous]

Hi Guys,

Can you possibly help me clean up below codes? The range of cells with data is from A:AD

1. Basically starting in AG5, I will create a sum formula from E5:T5 which will be copied down to the last non blank cell (not just till range 681).
2. The macro will hardcode the sum column and sort by descending.
3. If the sum total is zero it will create a separator by adding a row.
4. Afterwards, delete the sum column


Draft codes:
----------------------

Sub Macrotest()


ActiveCell.FormulaR1C1 = "=SUM(RC[-28]:RC[-13])"
Range("AG5").Select
Selection.Copy
ActiveWindow.SmallScroll Down:=-12
Range("AG5:AG681").Select
ActiveSheet.Paste
Rows("5:681").Select
Range("AG5").Activate
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Macro Sheet").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Macro Sheet").Sort.SortFields.Add Key:=Range( _
"AG5:AG681"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Macro Sheet").Sort
.SetRange Range("A5:AG681")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("AG:AG").Select
Range("AG26").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.End(xlUp).Select

End Sub

----------------------------------

Example Output (separate those with zero as total):

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]QTY[/TD]
[/TR]
[TR]
[TD]500[/TD]
[/TR]
[TR]
[TD]100[/TD]
[/TR]
[TR]
[TD]50[/TD]
[/TR]
[TR]
[TD]20[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]0[/TD]
[/TR]
[TR]
[TD]0[/TD]
[/TR]
</tbody>[/TABLE]



Any help will be much appreciated


Thank you!

 

[baitmaster]

I haven't added the row yet as I'm unclear what the requirement is. Do you just want to split the results table at the point [if] the first zero total is encountered?

You'll note I've not used any Select, I'm always referring to the actual objects I want to work with

Option Explicit

Sub Macrotest()


' create worksheet object, using VBA codename not Excel name
Dim ws As Worksheet: Set ws = Sheet1


' create range objects for where formulas will be written
Dim rngStart As Range: Set rngStart = ws.Range("AG5")
Dim rngEnd As Range: Set rngEnd = ws.Cells(lastUsedRow(ws), rngStart.Column)


With Range(rngStart, rngEnd)
    .FormulaR1C1 = "=SUM(RC[-28]:RC[-13])"                  ' write formulas
    .Value = .Value                                         ' convert to values
    
    With ws.Sort                                            ' perform sort feature
        .SortFields.Clear
        .SortFields.Add Key:=Range(rngStart, rngEnd), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SetRange Range(Cells(rngStart.Row, 1), rngEnd)     ' looks at column 1, this could be changed if necessary
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


    .ClearContents                                          ' remove formulas


End With


End Sub




Function lastUsedRow(ws As Worksheet) As Long
' function to find last used row of worksheet


On Error Resume Next
    lastUsedRow = ws.Cells.Find("*", Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
On Error GoTo 0


End Function

 

[baitmaster]

additional code, now I've noticed the results table that explains what you want...

    ' find change from non-zero to zero and insert a row
    Dim i As Integer
    For i = 2 To .Cells.Count
        If .Cells(i - 1, 1) > 0 And .Cells(i, 1) = 0 Then .Cells(i, 1).EntireRow.Insert
    Next i
    
    .ClearContents                                          ' remove formulas


End With

 

[DanteAmor]

How about:

Sub Macrotest()
    Dim r As Range, f As Range
    Set r = Range("AG5:AG" & ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row)
    With r
        .FormulaR1C1 = "=SUM(RC[-28]:RC[-13])"
        .Value = .Value
        Range("A5", r).Sort key1:=Range("AG5"), order1:=xlDescending, Header:=xlNo
        Set f = .Find(0, LookIn:=xlValues, lookat:=xlWhole)
        If Not f Is Nothing Then f.EntireRow.Insert
        .ClearContents
    End With
End Sub

 

[unknownymous]

Thank you baitmaster & DanteAmor. I'll go for the simplified one.

 

[DanteAmor]

Thank you baitmaster & DanteAmor. I'll go for the simplified one.

I'm glad to help you. Thanks for the feedback.