View Full Version : [SOLVED:] Insert row & total other columns
rs33olol
06-14-2016, 07:25 AM
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
06-14-2016, 10:51 AM
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
06-14-2016, 11:20 AM
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
06-14-2016, 11:37 AM
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
06-14-2016, 11:40 AM
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
06-14-2016, 11:41 AM
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
06-14-2016, 11:43 AM
Exactly. Does all insert totals but the last item.
p45cal
06-14-2016, 12:33 PM
A small sample file with a sheet for before data and a sheet for after data please.
rs33olol
06-14-2016, 12:59 PM
Thanks again.
offthelip
06-14-2016, 03:51 PM
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
06-14-2016, 08:52 PM
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
06-15-2016, 08:07 AM
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.