Как правильно переписать код- сумма строк - вывод в столбцы?

Question

Всем привет, есть строки, необходимо посчитать сумму 4 строк - вывести в сумму в столбец рядом, взять следующий диапазон из 4-х ячеек - сложить их и вывести результат в столбец рядом в ячейку ниже

Ручной код:

Sub mmm()
Dim cellABC As Integer
Dim sum As Integer

cellABC = 2

Cells(2, cellABC) = WorksheetFunction.sum(Range("A2:A5"))
Cells(3, cellABC) = WorksheetFunction.sum(Range("A6:A9"))
Cells(4, cellABC) = WorksheetFunction.sum(Range("A10:A13"))
End Sub

Пытаюсь переписать логику?

Sub ppp()
Dim i, j, cellABC, startD, EndD As Integer
Dim sum As Integer

cellABC = 2
For i = 2 To 11
    Cells(i, cellABC) = WorksheetFunction.sum(Range("A" & ((i - 2) * 4 + 2) & ":A" & ((i - 1) * 4 + 5)))
Next i
End Sub

Но результат не корректно считается. Как можно исправить??? Спасибо

Answer 1

Sub SumOfRanges()
    Dim Rng As Range
    Dim rowResult As Long
    Dim i As Long
    
    With Worksheets("sheet1")
        Set Rng = .Range("A2:A13")
        rowResult = Rng.Row
        
        For i = 1 To Rng.Rows.Count Step 4
            .Cells(rowResult, 2).Value = WorksheetFunction.sum(.Range("A2:A5").Offset(i - 1, 0))
            ' или ...sum(Rng.Offset(i - 1, 0).Resize(4, 1))'
            rowResult = rowResult + 1
        Next i
    End With
End Sub

Для нескольких диапазонов суммирования такой "писанины" достаточно. Для большого диапазона нужна оптимизация (код ниже)

Sub SumOfRanges2()
    Dim arr_()
    Dim sum_ As Double
    Dim i As Long, k As Long
    Const step As Long = 4
    
    Call ReceivingData(arr_())
    ReDim Preserve arr_(1 To UBound(arr_), 1 To 2)
   
    For i = 1 To UBound(arr_)
        sum_ = sum_ + arr_(i, 1)
        If i Mod step = 0 Then Call SaveSum(arr_, sum_, k)
    Next i
    
    If fMultiplicity(UBound(arr_), step) Then Call SaveSum(arr_, sum_, k)
    Call ResultPerSheet(arr_)
End Sub
'-----------------'
Sub SaveSum(arr_(), sum_ As Double, k As Long)
    k = k + 1
    arr_(k, 2) = sum_
    sum_ = 0
End Sub
'-----------------'
Sub ReceivingData(arr_())
    Dim LastRow As Long
    
    With Worksheets("sheet1")
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr_ = .Range("A2:A" & LastRow).Value
    End With
End Sub
'-----------------'
Sub ResultPerSheet(arr_())
    Worksheets("sheet1").Range("A2").Resize(UBound(arr_), UBound(arr_, 2)).Value = arr_
End Sub
'-----------------'
Function fMultiplicity(max As Long, step As Long) As Boolean
    fMultiplicity = (max - (max Mod step) + 1) <= max
End Function

Answer 2

Вариант с формулой

Sub nnn()
    With ActiveSheet.Range("B2:B4")
        .FormulaR1C1 = "=SUM(OFFSET(R2C1,(ROW()-2)*4,0):OFFSET(R2C1,(ROW()-2)*4+3,0))"
        .Value = .Value
        .Parent.Calculate ' необязательно, только если включен ручной пересчет формул
    End With
End Sub

БЛОГ НА HUSL

Как правильно переписать код- сумма строк - вывод в столбцы?

Ответы (2 шт):