条件が満たされてから合計行が新しい行を追加する

Question

名前の行全体をループし、人の「合計」行を結合してすべての列を合計するプロセスを考えています。

以下の画像例では、Person 1の値のすべてを「Person 1 total」というラベルの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列の値を前の行の値に設定するため、問題が発生していました。あなたのコードが再びループを通過すると、新しく挿入された値を見て、その値が前の行と同じであるが次の行とは異なるので、さらに別の新しい行を挿入することになります。広告無限

下から上向き作業してみてください。

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