Calculating sum and grouping of dynamic range

Question

I'm trying to create a Macro to select and group a certain amount of cells with implementation of some formulas, a simple example picture is included below. The only thing that should determine the range is column A.

Let's say the active cell is somewhere between row 2 and row 9, the Macro should be able to find out that row 1 and row 10 are the boundaries of that range because of the presence of values in column A and so creating and selecting a range going from row 2 till row 9. I tried to loop through the cells going down to find the first row with an active value in column A. After determining the range/group, a formula, calculating the product of those rows, and to finish it of, calculatie a sum of those products in the title row of that group (being the upper row with an active value in column A).

I've included my code so far below, after a bit of trial and error and googling/searching for similar problems on this forum, but my code still doesn't seem to work like I want it to. My not that great knowledge of VBA/scripting doesn't really help :)

A picture is included below with the wanted generated formulas colored in blue.

    Dim StartCell, EindCell As Range
    Dim teller As Integer
    Dim teller2 As Integer
Cells(Application.ActiveCell.Row, 1).Select
teller = 0
Do While Selection.Offset(teller, 0).Value = ""
    teller = teller - 1
Loop
Selection.Offset(teller, 0).Select
Set StartCell = ActiveCell
teller2 = 0
Do While Selection.Offset(teller, 0).Value = ""
    teller = teller + 1
Loop
Selection.Offset(teller, 0).Select

    Set EindCell = ActiveCell
    Range(StartCell, EindCell).Select
    Selection.Rows.Group

    Cells(Application.ActiveCell.Row, 8).Select
    ActiveCell.Formula = "=PRODUCT(RC[-4]:RC[-1])"
    Selection.NumberFormat = "0.00"
    Range(StartCell.Row + 1, 9).Formula = "=sum(cells(StartCell.row,8):Cells(EindCell.row,8))"

Answer 1

Please try this code.

Sub SumGroup()
    ' 12 Jan 2018

    Dim Rng As Range
    Dim Rstart As Long, Rend As Long
    Dim R As Long

    R = ActiveCell.Row
    If Len(Cells(R, "A").Value) Then R = R + 1
    Rstart = R
    Do Until Len(Cells(Rstart - 1, "A").Value)
        Rstart = Rstart - 1
    Loop
    Rend = R
    R = Cells(Rows.Count, "D").End(xlUp).Row
    Do Until Len(Cells(Rend + 1, "A").Value)
        Rend = Rend + 1
        If Rend = R Then Exit Do
    Loop

    Set Rng = Range(Cells(Rstart, "H"), Cells(Rend, "H"))
    With Rng
        .Formula = "=PRODUCT(RC[-4]:RC[-1])"
        .NumberFormat = "0.00"
        Cells(Rstart - 1, .Column + 1).Formula = "=SUM(" & .Address & ")"
        Cells(Rstart - 1, .Column + 1).NumberFormat = "0.00"
    End With
End Sub

Answer 2

This works for however many groups you have in one sheet. If the user selects a cell past the last used row then it'll assume they meant the last group

Sub tester()

    Dim myRow As Long
    Dim topRow As Long
    Dim botRow As Long
    Dim lastRow As Long

With ActiveSheet

    myRow = Selection.Row   ' get selected row
    lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row ' get last row in col A
    If lastRow <= myRow Then myRow = lastRow - 1 ' check that selected row is not past the last row

RETRY:
    topRow = myRow      ' initiate top and bottom row variables to same as select row
    botRow = myRow + 1

    Do While .Cells(topRow, 1).Value = "" ' cycle up until finds entry
        topRow = topRow - 1
    Loop

    Do While .Cells(botRow, 1).Value = "" ' cycle down until finds entry
        botRow = botRow + 1
    Loop

    topRow = topRow + 1 ' correct range
    botRow = botRow - 1

    If topRow - 1 = botRow Then myRow = myRow - 1: GoTo RETRY ' if user selected last entry in group in col A then it'll assume this was toprow, correct selection row and try again.

    With .Range(Cells(topRow, 8).Address, Cells(botRow, 8).Address)
        .Formula = "=PRODUCT(RC[-4]:RC[-1])"
        .NumberFormat = "0.00"
    End With

    .Range("I" & topRow - 1).Formula = "=SUM(" & Cells(topRow, 8).Address & ":" & Cells(botRow, 8).Address & ")"

End With

End Sub

Answer 3

I believe the code below will do what you expect:

Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your Sheet, change Sheet1 as required
LastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
'find the last row in column D
ws.Cells(1, 9).FormulaR1C1 = "=SUM(R[1]C[-1]:R[50]C[-1])"
'enter the Sum formula on row 1 column 9, Range I1
For i = 1 To LastRow 'loop from row 1 to last
    If ws.Cells(i, 7) <> "" Then ws.Cells(i, 8).FormulaR1C1 = "=PRODUCT(RC[-4]:RC[-1])"
    'if there is data on Column 7 (G) then add formula to column 8 (H)
Next i
End Sub