插入基于ID分组的小计公式

Question

我试图创建一个代码，将插入一个 小计 它将只对列中具有正确ID分组的单元格进行求和（ID分组由其前2或3位数字识别）。

到目前为止，我成功地实现了我需要实现的目标，只有当有以下情况时，才会有这样的结果 连续ID值 在每一行中。当我有空白行时，代码不能正常运行，我无法弄清这部分。

任何建议将是非常感激它 请看下面的图片，理解起来更容易一些。

目前的结果与我发布的代码与颜色可视化代码分组。

在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

使用数组循环的修改方法

由于通过VBA循环浏览单元格很耗时，我选择了一种数组的方法，步骤如下。

• [0] 通过将数据分配到一个基于变体1的2-dim数据域数组来获取数据。v,
• [1] 通过逐一比较邻居ID来分析数据，通过 If nxtId > curId Then.

如果这个比较显示为真，那么下一行就会有一个新的ID(i+1)，你就必须在当前位置上求和。i 输入和公式（覆盖当前元素）。

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

请注意，为了更好地阅读，我把公式中的范围地址改成了顶部单元格，而不是下面的行()，即使Excel可以处理这个问题。

• [2] 公式一次性写入目标列，通过.Range("C1").Resize(UBound(v), 1).Formula2 = v

问题

"当我有空白行的时候，代码不能正常运行，我想不通这部分。"

诀窍是忘记重新定义当前的id值，如果当前单元格值是 虚空 并记住之前的id定义。

当前和下一个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

帮助过程返回数值比较所需的邻域ID值。

方法。 通过以下方法执行截断 \ 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