Insert row & total other columns

[rs33olol]

Ok, so I need to insert rows based on a change in column A then add totals to those inserted areas for columns O,P,Q. If I could've done it w/ the subtotals functionality I would have but it's not feasible in this instance. So I've got the code to insert the rows at the column change but I'm struggling w/ then adding the totals in those inserted areas. Here's what i have for the insert:
Dim lRow As Long
For lRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row To 2 Step -1
If Cells(lRow, "A") <> Cells(lRow - 1, "A") Then Rows(lRow).EntireRow.Insert
Next lRow

Any help on the code to get to add totals for O,P,Q in the inserted areas is greatly appreciated. Thanks.
Rob

[offthelip]

Try this:
Dim lRow As Long
firstinsert = True
For lRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row To 2 Step -1
If Cells(lRow, "A") <> Cells(lRow - 1, "A") Then
Rows(lRow).EntireRow.Insert
If Not (firstinsert) Then
If lastrowinserted - lRow > 1 Then
Cells(lastrowinserted + 1, 15).Formula = "=sum(O" & lRow & ":O" & lastrowinserted & ")"
End If
End If
lastrowinserted = lRow
firstinsert = False
End If
Next lRow

[rs33olol]

Thanks. Ok, so this worked really well for the first insert & put the total in column O. However, I have to total the 2nd rollup of column A as well and it didn't put those totals in at the bottom. So in this example, I'd also want Co. B to show its totals (total of 6) at the bottom but it's not.



Companies (Col A)
AcctName (Col O)


Co. A
1


Co. A
2


Co. A
3


Co. A
4


Co. A
1


Co. A
2


Co. A
3



16


Co. B
2


Co. B
2


Co. B
2

[offthelip]

all you need to do is add extra line for eahc column you need;
Cells(lastrowinserted + 1, 15).Formula = "=sum(O" & lRow & ":O" & lastrowinserted & ")"
Cells(lastrowinserted + 1, 16).Formula = "=sum(P" & lRow & ":P" & lastrowinserted & ")"
Cells(lastrowinserted + 1, 17).Formula = "=sum(Q" & lRow & ":Q" & lastrowinserted & ")"

I thought that was obvious , sorry, assumptions can easily be wrong!!

[offthelip]

Sorry I misunderstood the problem, the problem is with the initalisation, we need to start the programm with the endup row and put an equation in there.
as it is as the moment it does them all except the last item.

[rs33olol]

No, the O,P,Q was fine. It was obvious. Its that the 2nd level of data isn't summing at the bottom. So company B in my example doesn't have a total for it at the bottom like company A does.

[rs33olol]

Exactly. Does all insert totals but the last item.

[p45cal]

A small sample file with a sheet for before data and a sheet for after data please.

[rs33olol]

Thanks again.

[offthelip]

Apologies for delay in replying I had to go out,
try this, i have just changed the initialisation:

Dim lRow As Long
lastrowinserted = Cells(Cells.Rows.Count, "A").End(xlUp)
For lRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row + 1 To 2 Step -1
If Cells(lRow, "A") <> Cells(lRow - 1, "A") Then
Rows(lRow).EntireRow.Insert
If lastrowinserted - lRow > 1 Then
Cells(lastrowinserted + 1, 15).Formula = "=sum(O" & lRow & ":O" & lastrowinserted & ")"
End If
lastrowinserted = lRow
End If
Next lRow

[jolivanes]

Try this maybe on a copy of your workbook

Sub InsertRowSubtotal()
Dim i As Long
Dim LastRow As Long
Dim fRepeat
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
For i = LastRow To 2 Step -1
If .Cells(i, "A").Value <> .Cells(i + 1, "A").Value Then
.Rows(i + 1).Insert
.Cells(i + 1, "A").Value = "Total " & Cells(i, "A").Value
.Cells(i + 1, "O").Value = WorksheetFunction.SumIf(Range("A1:A1000"), Cells(i, "A"), Range("O1:O1000"))
.Cells(i + 1, "P").Value = WorksheetFunction.SumIf(Range("A1:A1000"), Cells(i, "A"), Range("P1:P1000"))
.Cells(i + 1, "Q").Value = WorksheetFunction.SumIf(Range("A1:A1000"), Cells(i, "A"), Range("Q1:Q1000"))
fRepeat = True
End If
Next i
End With
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub

[p45cal]

If I could've done it w/ the subtotals functionality I would have but it's not feasible in this instance.I'm curious as to why not.
The following uses the Subtotals functionality to get what I think you want. See comments in the code on how you might want to miss out some lines of code to get what you want. Test it on your sample file.
I say ''what I think you want' as I can't see any difference at all between the before and after sheets!
Sub blah()
'add temporary header:
Range("A1:R1").Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1:R1").Value = "Hdr"
'Group and subtotal:
Range("A1").CurrentRegion.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(15, 16, 17), Replace:=True
'ungroup:
Range("A1").CurrentRegion.Rows.Ungroup
Range("A1").CurrentRegion.Rows.Ungroup
'remove subtotal and grand total labels in column A:
Range("A1").CurrentRegion.Columns(2).SpecialCells(xlCellTypeBlanks).Offset(, -1).Clear
'remove entire grand total row:
Range("A1").CurrentRegion.Rows(Range("A1").CurrentRegion.Rows.Count).Delete shift:=xlUp
'remove temporary header.
Range("A1:R1").Delete shift:=xlUp
End Sub