Insert rows at certain interval; copy and/or sum data above interval

Question

My question concerns test data which I would like to 'summarize' every three rows (please see image below).

I would like to insert after every three rows an empty row and fill it according to the image I added: copy info from the row above or sum the data from the three rows above.

Ideally, at the end: all newly inserted rows should be copied to a new worksheet.

I already managed to insert a row every three rows, but the next steps are beyond my programming skills in Excel VBA...

Sub InsertRowsAtIntervals()

Dim Rng As Range
Dim xInterval As Integer
Dim xRows As Integer
Dim xRowsCount As Integer
Dim xNum1 As Integer
Dim xNum2 As Integer

Dim WorkRng As Range
Dim xWs As Worksheet
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
xRowsCount = WorkRng.Rows.Count
xInterval = 2
xRows = 1
xNum1 = WorkRng.Row + xInterval
xNum2 = xRows + xInterval

Set xWs = WorkRng.Parent
For i = 1 To Int(xRowsCount / xInterval)
    xWs.Range(xWs.Cells(xNum1, WorkRng.Column), xWs.Cells(xNum1 + xRows - 1, WorkRng.Column)).Select
    Application.Selection.EntireRow.Insert
    xNum1 = xNum1 + xNum2
Next



End Sub

Answer 1

If your goal is to sum or extract data every three rows, then that can be done without VBA, using formulas that don't destroy the source data.

If your source data starts in row 1, you can use this formula, starting in row 2 and copy down:

to sum values in groups of 3 rows:

=SUM(INDEX(A:A,((ROW()-1)*3)-2):INDEX(A:A,((ROW()-1)*3)))

To get every third value

=INDEX(B:B,((ROW()-1)*3))

Again, the formulas start in row 2, otherwise the result will be different.

Answer 2

Insert Sub Totals

• Adjust the constants including the workbook. Near the bottom of the Sub there are two more constants.
• Target only contains the values of the subtotal rows, while Result contains values of the complete (resulting) range including the subtotal rows.
• While testing, Result will be written to a third worksheet.
• After testing and if you still feel like overwriting the original data, in the Sub out-comment or delete the lines from Either to Or and uncomment the last line.

The Code

Option Explicit

Sub insertSubTotals()

    ' Source
    Const srcName As String = "Sheet1"
    Const FirstRow As Long = 1
    Const RowInterval As Long = 3
    Const FirstSumColumn As Long = 3
    Const ColInterval As Long = 2
    Const Cols As String = "A:Q"
    ' Target
    Const tgtName As String = "Sheet2"
    Const tgtFirstCell As String = "A1"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim src As Worksheet: Set src = wb.Worksheets(srcName)

    ' Write values from Source Range to Source Array.
    Dim rng As Range
    Set rng = getColumnRange(src, src.Columns(Cols).Column, FirstRow)
    If rng Is Nothing Then Exit Sub
    Dim Source As Variant
    Source = rng.Resize(, src.Columns(Cols).Columns.Count)
    Set rng = Nothing

    ' Write values from Source Array to Target and Result Arrays.
    Dim UB1 As Long: UB1 = UBound(Source)
    Dim UB2 As Long: UB2 = UBound(Source, 2)
    Dim Target As Variant: ReDim Target(1 To Int(UB1 / RowInterval), 1 To UB2)
    Dim Result As Variant: ReDim Result(1 To UB1 + UBound(Target), 1 To UB2)
    Dim i As Long, j As Long, k As Long, m As Long, o As Long, q As Long
    Dim CurrVal As Double
    For i = 1 To UB1
        k = k + 1
        For j = 1 To UB2
            Result(k, j) = Source(i, j)
        Next j
        If i Mod RowInterval = 0 Then
            k = k + 1: m = i - RowInterval + 1: q = q + 1: CurrVal = 0
            For j = 1 To UB2
                If j >= FirstSumColumn And j Mod ColInterval _
                  = FirstSumColumn Mod ColInterval Then
                    For o = m To m + RowInterval - 1
                        CurrVal = CurrVal + Source(o, j)
                    Next o
                Else
                    CurrVal = Source(i, j)
                End If
                Result(k, j) = CurrVal
                Target(q, j) = CurrVal
            Next j
        End If
    Next i

    ' Write values from Target Array to Target Range.
    wb.Worksheets(tgtName).Range(tgtFirstCell).Resize(q, UB2) = Target

    ' Either:
    ' While testing, write values from Result Array to Result Range.
    Const resName As String = "Sheet3"
    Const resFirstCell As String = "A1"
    wb.Worksheets(resName).Range(resFirstCell).Resize(k, UB2) = Result
    ' Or:
    ' Write values from Result Array to Result Range (overwrite).
    'wb.Worksheets(srcName).Columns(colls).Cells(1).Resize(k, UB2) = Result

End Sub

Function getColumnRange(Sheet As Worksheet, _
                        ByVal AnyColumn As Variant, _
                        ByVal FirstRow As Long) As Range
    Dim rng As Range
    Set rng = Sheet.Columns(AnyColumn).Find("*", , xlValues, , , xlPrevious)
    If rng Is Nothing Then Exit Function
    If rng.Row < FirstRow Then Exit Function
    Set getColumnRange = Sheet.Range(Sheet.Cells(FirstRow, AnyColumn), rng)
End Function