Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Автоматически расставить формулу с функцией ПРОМЕЖУТОЧНЫЕ ИТОГИ для суммирования
 
#1
15.10.2021 12:28:40
Добрый день. Есть некий файл с расчетом на тысячи строк ( во вложении) в строках, выделенных желтым цветом необходимо в последнем столбце поиметь формулу типа =ПРОМЕЖУТОЧНЫЕ.ИТОГИ(9;<диапазон>) , таких строк сотни в оригинале. Диапазон для каждой формулы в каждой желтой строке должен начинаться сразу после желтой строки и заканчиваться перед следующей желтой строкой.
Вопрос: как автоматически расставить такую формулу, чтобы диапазоны руками не править ручками?
 
 
 
#2
15.10.2021 12:51:53
Код
Option Explicit

Sub FillSubtotalFormula()
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim y As Long
    With ActiveSheet
        For y = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
            If .Cells(y, 1).Interior.Color = 65535 Then
                dic.Item(y) = 0
            End If
        Next
        If dic.Count > 0 Then
            dic.Item(y) = 0
            Dim arr As Variant
            arr = dic.Keys()
            Set dic = Nothing
            
            Dim Application_Calculation As Long
            Application_Calculation = Application.Calculation
            Application.Calculation = xlCalculationManual
            For y = 0 To UBound(arr) - 1
                If arr(y + 1) > arr(y) + 1 Then
                   .Cells(arr(y), 1).Range("D1:H1").FormulaR1C1 = "=SUBTOTAL(9,R[1]C:R" & arr(y + 1) - 1 & "C)"
                End If
            Next
            Application.Calculation = Application_Calculation
        End If
    End With
End Sub
А если не хочется использовать макрос, то можно в дополнительный столбец вставить признак. Что-то вроде "I2          =I1".
С помощью автофильтра отобрать жёлтые строки. Поменять признак. И формулу заменить на СУММЕСЛИМН().
Изменено: МатросНаЗебре - 15.10.2021 12:57:57
 
 
 
#3
27.10.2021 09:08:30
Цитата
МатросНаЗебре написал:
А если не хочется использовать макрос,
Спасибо за макрос! А можно его скорректировать, чтобы он обрабатывал только тот столбец, где установлен курсор? Сейчас макрос кучу мусора добавляет во все ячейки, которые желтым раскрашены
 
 
 
#4
27.10.2021 09:35:20
Код
Option Explicit

Sub FillSubtotalFormula()
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim y As Long
    With ActiveSheet
        Dim xSelection As Integer
        xSelection = ActiveCell.Column
        
        For y = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
            If .Cells(y, xSelection).Interior.Color = 65535 Then
                dic.Item(y) = 0
            End If
        Next
        If dic.Count > 0 Then
            dic.Item(y) = 0
            Dim arr As Variant
            arr = dic.Keys()
            Set dic = Nothing
             
            Dim Application_Calculation As Long
            Application_Calculation = Application.Calculation
            Application.Calculation = xlCalculationManual
            For y = 0 To UBound(arr) - 1
                If arr(y + 1) > arr(y) + 1 Then
                   .Cells(arr(y), xSelection).FormulaR1C1 = "=SUBTOTAL(9,R[1]C:R" & arr(y + 1) - 1 & "C)"
                End If
            Next
            Application.Calculation = Application_Calculation
        End If
    End With
End Sub
 
 
 
Страницы: 1
Наверх