VBA 分组并插入摘要行

Question

首先：我很抱歉，因为我在 VBA 上花费的时间很少。我有这样的数据：

金额 |分类
2.00 |猫1
4.00 |猫1
3.00 |猫2
5.00 |猫3

我希望它最终变成这样：

金额 |分类
2.00 |猫1
4.00 |猫1
总计：6.00 |猫1
3.00 |猫2
总计：3.00 |猫2
5.00 |猫3
总计：5.00 |猫3

我发现插入一行的代码是：

Sub InsertRowAtChangeInValue() 
Dim lRow As Long 
For lRow = Cells(Cells.Rows.Count, "B").End(xlUp).Row To 2 Step -1 
    If Cells(lRow, "B") <> Cells(lRow - 1, "B") Then Rows(lRow).EntireRow.Insert 
Next lRow 
End Sub 

效果很好，但我不确定如何对创建的行执行任何操作。帮助？谢谢！

Answer 1

如果您使用 VBA 的工作不多，那么开始熟悉某些结构的任何简单方法都是记录您要执行的步骤的宏并查看生成的代码。

请记住，宏记录是一步一步进行的，因此会记录一些丑陋的东西，例如屏幕移位。由于录制的宏没有错误陷阱，而且我从未见过录制的宏创建循环的实例。

请记住，您的代码假定数据始终从当前工作表的 A1 开始。

您需要添加一些代码来获取您要查找的内容。我会将您的代码转换为：

Sub InsertRowAtChangeInValue()
 Dim lRow As Long
 Dim cRow As Long
 Dim sSum As Long
 Dim formula As String
 'Stops screen updating and improves run times
 Application.ScreenUpdate = False
 'Start at row 3 because row 1 is a header so row 2 is first line of data
 cRow = 3
 'sSum is the start of Sum. The first row you might sum is 2.
 sSum = 2
 'Because of the sums easier to step down instead of up
 'Add 2 to last row to allow for the last sum
 lRow = Cells(Cells.Rows.Count, "B").End(xlUp).Row + 2
 Do Until cRow = lRow
     If Cells(cRow, "B") <> Cells(cRow - 1, "B") Then
          Rows(cRow).EntireRow.Insert
          Cells(cRow, "A").Select
          'Insert the formula
          ActiveCell.formula = "=""Total: """ & "& SUM(A" & sSum & ":A" & cRow - 1 & ")"
          'Update column B
          Cells(cRow, "B").Value = Cells(cRow - 1, "B")
          'Increase the next sum to the row after the one you just added.
          sSum = cRow + 1
          'Increase the last row count
          lRow = lRow + 1
          'Check to make sure you are not at the bottom of the workbook
          If cRow = 65536 Then
               cRow = lRow
          Else
               cRow = cRow + 2
          End If
     Else
          'Increment if the rows are the same in column B
          'Check if you are at the bottom of the workbook
          If cRow = 65536 Then
               cRow = lRow
          Else
               cRow = cRow + 1
          End If
     End If
 Loop
 Application.ScreenUpdating = True
End Sub

我添加了一些 cmets 来尝试解释发生了什么。