Добавить новую строку, если условия выполнены, а затем сумма столбцов

Question

Я ищу, чтобы создать процесс, который проходит всю строку имен и объединяет строки «Всего» и суммирует все столбцы вместе.

В приведенном ниже примере изображения хотелось бы, чтобы все значения Person 1 суммировались в 1 строку с надписью «Общее количество человек 1». Затем удалите предыдущие строки «Всего». Затем перейти на человека 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 этой новой строки в значение из предыдущей строки. Когда ваш код снова прошел цикл, он будет смотреть на вновь вставленное значение, решив, что его значение совпадает с предыдущей строкой, но отличается от следующей строки и, следовательно, вставляет еще одну новую строку. Ad infinitum.

Попробуйте, начиная с нижней и работать вверх:

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