Суммирование не смежных диапазонов

[aks_sv]

Здравствуйте!
У меня вопрос. Имеется столбец с непрерывным диапазоном чисел, затем через строку опять непрерывный диапазон и т.д.. Количество чисел в непрерывных диапазонах и количество диапазонов может меняться. Как с помощью VBA вставить в пустые строки формулы (именно формулы, а не результат) суммы чисел непрерывных диапазонов?

5
8
1
1

2
8
9

7
6
6

Заранее благодарен.

[VictorM]

так что ли?
5
8
1
1
=СУММ(A1:A4)
2
8
9
=СУММ(A6:A8)
7
6
6
=СУММ(A10:A12)

[aks_sv]

Именно так, только чтобы эти формулы вставлялись с помощью VBA

[Pavel55]

Ну, если без красоты и не очень критично время выполнения макросом, то наверное так

Код: Выделить всё

Sub Макрос1()
    'для столбца А
    Cells(Rows.Count, 1).End(xlUp).Select
    Do
        With ActiveCell
            .Offset(1, 0).FormulaLocal = "=СУММ(" & ActiveCell.Address(0, 0) & ":" & ActiveCell.End(xlUp).Address(0, 0) & ")"
            .Offset(1, 0).Font.Bold = True
            .End(xlUp).Select
            ActiveCell.End(xlUp).Select 'хм. без ActiveCell не срабатывает
        End With
    Loop While ActiveCell.Row <> 1
    MsgBox "Done!", 64, ""
End Sub

[aks_sv]

Спасибо, оказалось не так сложно, как я думал.

[aks_sv]

Pavel55,

Sub Макрос1() 'для столбца А Cells(Rows.Count, 1).End(xlUp).Select Do With ActiveCell .Offset(1, 0).FormulaLocal = "=СУММ(" & ActiveCell.Address(0, 0) & ":" & ActiveCell.End(xlUp).Address(0, 0) & ")" .Offset(1, 0).Font.Bold = True .End(xlUp).Select ActiveCell.End(xlUp).Select 'хм. без ActiveCell не срабатывает End With Loop While ActiveCell.Row <> 1 MsgBox "Done!", 64, "" End Sub

Почему то если в последнем диапазоне одно число, макрос работает не правильно.

[VictorM]

Вариант макроса. Написан только для проверки алгоритма и поэтому не оптимизировался.
В принципе похож на Pavel55, только работает "сверху" и проверяет последний диапазон.
Хотя в условии не было указано, что диапазон может содержать одно значение.

Код: Выделить всё

Sub Макрос2()
    Range("A1").Select 'активируем для столбца А, т.к. не знаю, как оно будет у Вас
    Do
    iAddress = ActiveCell.Address(RowAbsolute:=False, ColumnAbsolute:=False)
    Selection.End(xlDown).Select
    If ActiveCell.Row = 65536 Then
        Cells(Rows.Count, 1).End(xlUp).Select
        iAddress = ActiveCell.Address(RowAbsolute:=False, ColumnAbsolute:=False)
        ActiveCell.Offset(1, 0).FormulaLocal = "'=СУММ(" & iAddress & ":" & iAddress & ") "
     Exit Do
    End If
    eAddress = ActiveCell.Address(RowAbsolute:=False, ColumnAbsolute:=False)
    ActiveCell.Offset(1, 0).FormulaLocal = "'=СУММ(" & iAddress & ":" & eAddress & ") "
    ActiveCell.Offset(2, 0).Select
    Loop While ActiveCell.Value <> ""
End Sub

так может и любой другой диапазон может быть с одним значением?
тогда это работать тоже не будет

[VictorM]

При наличии вот такого диапазона
5
8
1
1

2

7
7
6

8
вот это:

Код: Выделить всё

Sub Макрос3()
    Range("A1").Select 'активируем для столбца А, т.к. не знаю, как оно будет у Вас
    Do
    iAddress = ActiveCell.Address(RowAbsolute:=False, ColumnAbsolute:=False)
    k = ActiveCell.Offset(1, 0)
    If k = "" Then
        iAddress = ActiveCell.Address(RowAbsolute:=False, ColumnAbsolute:=False)
        ActiveCell.Offset(1, 0).FormulaLocal = "'=СУММ(" & iAddress & ":" & iAddress & ") "
        ActiveCell.Offset(2, 0).Select
    Else
       Selection.End(xlDown).Select
       eAddress = ActiveCell.Address(RowAbsolute:=False, ColumnAbsolute:=False)
       ActiveCell.Offset(1, 0).FormulaLocal = "'=СУММ(" & iAddress & ":" & eAddress & ") "
       ActiveCell.Offset(2, 0).Select
    End If
    Loop While ActiveCell.Value <> ""
End Sub

работает. Опять же, без особых "красивостей". Только идея

[aks_sv]

VictorM,

Хотя в условии не было указано, что диапазон может содержать одно значение.

В обще-то в условии было сказано:

Количество чисел в непрерывных диапазонах и количество диапазонов может меняться.

Попробовал Ваш второй код - без проблем. Спасибо.

[aks_sv]

Pavel55, VictorM,
Подскажите где почитать про формулы в VBA?