Add new row if conditions are met then sum row

[SoPassive]

Hey all,

I am looking to come up with a process that loops through the entire name row and combines the Person's "Total" rows and sums all the columns together.

In the example image below I would like all of Person 1's values to be totaled into 1 row labeled "Person 1 total". Then delete the previous "Total" rows. Then move onto person 2.

Here is my code below, I seem to have an issue with it forever looping and creating rows, because it runs for at least 10 minutes and then runs out of memory.

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

I haven't been able to begin trying to sum all of the rows yet, just stuck on creating rows but if any of you could help me out that would be greatly appreciated.

Thanks.

 

[yky]

Press F8 to step through the code and you'll find that the code is stuck in an infinite loop. It is because the newly inserted row also meets the IF condition. So, the code just keeps inserting rows.

You can do it from bottom up. Try this:

Dim i As Integer

    For i = 20 To 2 Step -1    
    If Cells(i, 2).Value <> Cells(i - 1, 2).Value Then
    Cells(i, 2).EntireRow.Insert
    Cells(i, 2).Value = Cells(i - 1, 2).Value
    Cells(i, 3).Value = "newly inserted" '<- this tells which row is the newly inserted row
    End If
    Next i