Excel 根据ID分组插入小计公式

我正在尝试创建一个代码，该代码将插入一个小计公式，该公式将仅对列中具有另一列中引用的正确ID分组的单元格求和（ID组由其前2或3位数字标识）

到目前为止，只有当每行中都有连续的ID值时，我才能成功地实现我需要实现的目标。当我有空行并且我不能理解这部分时，代码不能正常工作

任何建议都将不胜感激！ 请参阅下面的图片，以便更容易地理解

我发布的带有彩色可视化代码分组的代码的当前结果。

在A中显示空行，即使出现空行，我也希望按代码进行小计。

由代码添加的公式

Sub insertSubtotalByID（）
最后一排一样长
使活动行变长
暗淡的唯一2一样长
暗淡的唯一3一样长
Dim PREVIQUEID2与长
Dim PREVIQUEID3的长度与
变暗副作用时间尽可能长
Application.ScreenUpdating=False
lastRow=工作表（“sheet5”）。单元格（工作表（“sheet5”）。行数，“A”）。结束（xlUp）。行
暗色的和白色的一样长
副W=1
divStart=1
uniqueID2=左（单元格（1，1）.值，2）
uniqueID3=左（单元格（1，1）。值，3）
prevuniqueID2=左（单元格（1，1）。值，2）
prevuniqueID3=左（单元格（1，1）。值，3）
对于i=1到最后一行
如果uniqueID2>0，则
如果uniqueID2>prevuniqueID2，则“如果当前ID大于以前的ID值
单元格（i-1,3）。公式=“=SUM（索引（$B:$B，ROW（））：”&“B”和divStart&“）
prevuniqueID2=左（单元格（i，1）。值，2）
divStart=i
i=i-1
其他的
如果我是最后一行的话
uniqueID2=左（单元格（i+1,1）.Value，2）”在下一行设置下一个ID，2个值
uniqueID3=左（单元格（i+1,1）.Value，3）”设置下一行的下一个ID，3个值
prevuniqueID2=左（单元格（i，1）.Value，2）'设置当前ID，2个值
prevuniqueID3=左（单元格（i，1）.Value，3）'设置当前ID，3个值
如果结束
如果结束
如果结束
如果i=lastRow，则单元格（lastRow，3）。公式=“=SUM（索引（$B:$B，ROW（））：”&“B”&divStart&”）
单元格（i，10）。值=唯一值2
接下来我
Application.ScreenUpdating=True
端接头

使用数组循环修改方法

由于通过VBA在单元格中循环可能很耗时，我选择了一种数组方法，步骤如下：

• [0]

  通过将数据分配给基于1的变型2维数据字段数组

  v

  获取数据

• [1]

  通过

  逐个比较相邻ID来分析数据，如果nxtId>curId，则
  
  

如果此比较结果为真，则下一行将跟随一个新ID（

i+1

），您必须在当前位置求和

i

输入总和公式（覆盖当前元素）：

请注意，为了更好的可读性，我还原了公式中的范围地址，因此从顶部单元格开始，而不是从下面的行（）开始，即使Excel可以处理这个问题

• [2]

  公式通过

  .Range（“C1”）.Resize（UBound（v），1）。公式2=v

问题

“当我有空行且无法理解此部分时，代码无法正常运行。”

诀窍是，如果当前单元格值为空，则忘记重新定义当前id值，而是记住先前的id定义

当前和下一个id值由示例调用下面列出的帮助过程

GetIDs

提供

示例调用

插入小计

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

帮助过程

getid

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

帮助过程返回数值比较所需的相邻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

Sub-getid（v，ByVal i等长，curId，nxtId）
'用途：计算和更改当前和下一个id值（但忽略curId的空单元格）
'提示：请注意，在通过引用传递最后两个参数时，帮助过程会更改这些参数
“[2a]获取当前和下一个ID作为长整数
如果Trim（v（i，1））为空字符串，则
curId=v（i，1）\1000'仅当ID为“”时重置当前ID
如果结束
nxtId=v（i+1，1）\1000'获取下一个ID
端接头

使用数组循环修改方法

由于通过VBA在单元格中循环可能很耗时，我选择了一种数组方法，步骤如下：

• [0]

  通过将数据分配给基于1的变型2维数据字段数组

  v

  获取数据

• [1]

  通过

  逐个比较相邻ID来分析数据，如果nxtId>curId，则
  
  

如果此比较结果为真，则下一行将跟随一个新ID（

i+1

），您必须在当前位置求和

i

输入总和公式（覆盖当前元素）：

请注意，为了更好的可读性，我还原了公式中的范围地址，因此从顶部单元格开始，而不是从下面的行（）开始，即使Excel可以处理这个问题

• [2]

  公式通过

  .Range（“C1”）.Resize（UBound（v），1）。公式2=v

问题

“当我有空行且无法理解此部分时，代码无法正常运行。”

诀窍是，如果当前单元格值为

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