Macro Create Sum and Separate Zeroes

unknownymous

Board Regular
Joined
Sep 19, 2017
Messages
249
Office Version
  1. 2016
Platform
  1. Windows
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):

QTY
500
100
50
20
0
0

<tbody>
</tbody>



Any help will be much appreciated


Thank you!
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
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

Code:
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
 
Upvote 0
additional code, now I've noticed the results table that explains what you want...

Code:
    ' 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
 
Last edited:
Upvote 0
How about:

Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,497
Messages
6,114,002
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top