Вставить формулу промежуточного итога на основе группировки идентификаторов

Question

Я пытаюсь создать код, который будет вставлять формулу промежуточного итога , которая будет суммировать только ячейки в столбце, которые имеют правильную группировку идентификаторов, указанную в другом столбце (группа идентификаторов идентифицируется своими первыми двумя или 3 цифры).

Пока я добиваюсь того, чего мне нужно достичь, только если в каждой строке есть последовательные значения идентификатора . Код работает неправильно, когда у меня есть пустые строки, и я не могу понять эту часть.

Любой совет был бы очень признателен! См. Изображения ниже, чтобы немного легче понять.

Текущие результаты с моим опубликованным кодом с цветовой визуализацией групп кодов.

Отображение пустых строк в A, и я хочу получить промежуточные итоги по коду, даже если появляются пустые строки.

Формула добавлена Код

Sub insertSubtotalByID()

Dim lastRow As Long
Dim activeRow As Long
Dim uniqueID2 As Long
Dim uniqueID3 As Long
Dim prevuniqueID2 As Long
Dim prevuniqueID3 As Long
Dim subRow As Long
Application.ScreenUpdating = False

lastRow = Sheets("sheet5").Cells(Sheets("sheet5").Rows.Count, "A").End(xlUp).Row

Dim divStartID As Long

subRow = 1
divStart = 1

uniqueID2 = Left(Cells(1, 1).Value, 2)
uniqueID3 = Left(Cells(1, 1).Value, 3)
prevuniqueID2 = Left(Cells(1, 1).Value, 2)
prevuniqueID3 = Left(Cells(1, 1).Value, 3)

For i = 1 To lastRow
     If uniqueID2 > 0 Then
        If uniqueID2 > prevuniqueID2 Then 'if current ID is greater than previous ID value
            Cells(i - 1, 3).Formula = "=SUM(INDEX($B:$B,ROW()):" & "B" & divStart & ")"
            prevuniqueID2 = Left(Cells(i, 1).Value, 2)
            divStart = i
            i = i - 1
        Else
            If i < lastRow Then

                uniqueID2 = Left(Cells(i + 1, 1).Value, 2) 'set next ID in next row, 2 values
                uniqueID3 = Left(Cells(i + 1, 1).Value, 3) 'set next ID in next row, 3 values
                prevuniqueID2 = Left(Cells(i, 1).Value, 2) 'set current ID, 2 values
                prevuniqueID3 = Left(Cells(i, 1).Value, 3) 'set current ID, 3 values

            End If
        End If

    End If

    If i = lastRow Then Cells(lastRow, 3).Formula = "=SUM(INDEX($B:$B,ROW()):" & "B" & divStart & ")"

    Cells(i, 10).Value = uniqueID2

Next i
Application.ScreenUpdating = True

End Sub

Answer 1

Модифицированный подход с использованием массива l oop

Поскольку цикл по ячейкам через VBA может занять много времени, я выбрал подход с использованием массива со следующими шагами:

• [0] получить данные, назначив их 2-мерному массиву полей данных на основе варианта 1 v,
• [1] анализировать данные, сравнивая идентификаторы соседей один за другим через If nxtId > curId Then.

Если это сравнение окажется истинным, за новым идентификатором последует следующая строка (i+1), и вам нужно будет суммировать в текущей позиции i, введя формулу суммы (перезапись текущий элемент):

   v(i, 1) = "=SUM($B$" & start & ":INDEX($B:$B,ROW()))"

Обратите внимание, что я вернул адрес диапазона в формуле для лучшей читаемости, таким образом, начиная с верхней ячейки вместо следующей строки (), даже если Excel может справиться с этим

• [2] Формулы записываются в целевой столбец сразу через .Range("C1").Resize(UBound(v), 1).Formula2 = v

Проблема

«Код не работает правильно, когда у меня есть пустые строки, и я не могу понять эту часть.»

Хитрость заключается в том, чтобы забыть переопределить текущее значение id, если текущее значение ячейки пусто и вместо этого запомнить предыдущее определение идентификатора.

Текущие и следующие значения идентификаторов предоставляются процедурой помощи GetIDs, указанной под примером вызова.

Пример вызова InsertSubTotals

Option Explicit                           ' declaration head of code module

Sub InsertSubtotals()
With Sheet5
    '[0] get data (by assigning them to a variant 1-based 2-dim array v)
    Dim lastRow As Long: lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    Dim v: v = .Range("A1:A" & lastRow)

    '[1] analyze data
    Dim start As Long: start = 1
    Dim i As Long
    For i = 1 To UBound(v) - 1          ' loop from 1st element to 2nd last element
        '[1a] get current and next ids
        Dim curId As Long, nxtId As Long
        GetIDs v, i, curId, nxtId       ' call help procedure listed below

        '[1b] calculate subtotal formulae
        v(i, 1) = ""
        If nxtId > curId Then           ' compare Ids
            v(i, 1) = "=SUM($B$" & start & ":INDEX($B:$B,ROW()))"
            start = i + 1               ' remember next ID start
        End If
    Next i

    '[1c] calculate last element's formula
    v(UBound(v), 1) = "=SUM($B$" & start & ":INDEX($B:$B,ROW()))"

    '[2 ] write formulae to target column
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    .Range("C:C") = vbNullString                    ' clear target
    .Range("C1").Resize(UBound(v), 1).Formula2 = v  ' write all formulae to sheet

End With
End Sub

Справочная процедура GetIDs

Справочная процедура возвращает значения идентификаторов соседей, необходимые для сравнения numeri c.

Метод: При выполнении усечения через \ 1000 значение ячейки, например, 096700, дает 96, 102600 - 102. Это основа для возможного сравнения на шаге [1b] в основной процедуре, где большее следующее значение, чем текущее, означает логическую необходимость суммирования.

Sub GetIDs(v, ByVal i As Long, curId, nxtId)
'Purpose: calculate and change current and next id values (but omitting empty cells for curId) 
'Hint:    Note that the help procedure changes the last 2 arguments as they are passed by reference
        '[2a] get current and next ids as Long Integer
        If Trim(v(i, 1)) <> vbNullString Then
           curId = v(i, 1) \ 1000      ' reset current ID only if ID <> ""
        End If
        nxtId = v(i + 1, 1) \ 1000     ' get next ID
End Sub