如果满足条件，则添加新行，然后对列进行求和

Question

我希望找到一个循环遍历整个名称行的过程，并结合Person＆＃39;＆＃34; Total＆＃34;行和所有列的总和。

在下面的示例图片中，我希望将所有Person 1的值合计为1行标记为＆＃34; Person 1 total＆＃34;。然后删除之前的＆＃34; Total＆＃34;行。然后转移到人2。

下面是我的代码，我似乎有一个问题，它永远循环和创建行，因为它运行至少10分钟，然后耗尽内存。

Sub Sum()

Dim r As Range
Dim cell As Range


Application.ScreenUpdating = False


'Set r = Range("B2:B15000") 'ACTUAL RANGE
Set r = Range("B2:B20") 'EXAMPLE RANGE
For Each cell In r
    If cell.Value = cell.Offset(-1, 0).Value And cell.Value <> cell.Offset(1, 0).Value Then
        cell.Offset(1).EntireRow.Insert
        cell.Offset(1, 0).Value = cell.Value
    End If
Next


Application.ScreenUpdating = True
Range("A2").Select 
End Sub

我还没有能够开始尝试对所有行进行求和，只是坚持创建行，但如果你们中的任何人能够帮助我，那将非常感激。

感谢。

Answer 1

您的问题发生了，因为在插入新行后，您将该新行中B列的值设置为上一行的值。当你的代码再次经过循环时，它将查看新插入的值，确定它的值与前一行相同但与下一行不同，因此插入另一个新行。无限无限。

尝试从底部开始向上工作：

Sub Sum()
    Dim lastRow As Long
    Dim myRow As Long

    Application.ScreenUpdating = False

    'lastRow = 20
    '  or
    lastRow = .Range("B" & Rows.Count).End(xlUp).Row

    For myRow = lastRow To 2 Step -1
        If Cells(myRow, "B").Value = Cells(myRow - 1, "B").Value And Cells(myRow, "B").Value <> Cells(myRow + 1, "B").Value Then
            Rows(myRow + 1).EntireRow.Insert
            Cells(myRow + 1, "B").Value = Cells(myRow, "B").Value
        End If
    Next

    Application.ScreenUpdating = True
    Range("A2").Select
End Sub

要执行您想要执行的基础任务，您实际上最好使用类似于以下伪代码

的流程

r = 2
lastRow = 15000 'or whatever

Do While r < lastRow

    various totals = various totals + corresponding values from row r

    If name on row r = name on row r+1 Then
        delete row r
        lastRow = lastRow - 1
    Else
        values on row r = corresponding totals
        set all totals = 0
        r = r + 1
    End If

Loop