Insert rows with condition using macro

[Shazza]

It has been a while since I have coded anything and I am hoping someone can
help me.
I am wanting to do the following in one macro:-

1. Insert a row if value in column A doesn't match the next value
i.e.
Apple
Apple

Orange

2. At the beginning of each category then insert - shift cells down for
Column A and B and bold and total
i.e.
100
Apple Fruit 100
Apple Fruit 200 (should be bold)

if anyone can help if would be greatly appreciated and would end a list of
manual operations done by many individuals.

Cheers Sharon

 

[Per Jessen]

Hi Sharon

This should do it:

Dim FirstRow As Long
Dim TargetCol As String
Dim SumCol As String
Dim LastRow As Long
Dim counter As Long
Dim StartSum As Long
Dim EndSum As Long

Sub InsertRow_Total()

FirstRow = 2 'Assume headers in row 1
TargetCol = "A"
SumCol = "C"
counter = FirstRow
LastRow = Cells(Rows.Count, TargetCol).End(xlUp).Row
StartSum = FirstRow

Do
If Cells(counter, TargetCol).Value <> Cells(counter + 1,
TargetCol).Value Then
LastRow = LastRow + 1
Rows(counter + 1).Insert
Cells(counter, TargetCol).Resize(1, 2).Copy Cells(counter + 1,
TargetCol)
EndSum = counter
Cells(counter + 1, SumCol).Formula = "=sum(C" & StartSum & ":C" &
EndSum & ")"
Rows(counter + 1).Font.Bold = True
counter = counter + 2
StartSum = counter
Else
counter = counter + 1
End If
Loop Until counter = LastRow
Cells(counter, TargetCol).Resize(1, 2).Copy Cells(counter + 1, TargetCol)
Cells(counter + 1, SumCol).Formula = "=sum(C" & StartSum & ":C" & counter &
")"
Rows(counter + 1).Font.Bold = True
End Sub

Regards,
Per

 

[Shazza]

Hi Per,

Thanks for the code and it works a treat but I need a couple of
modifications and I am hoping you can assist:-

I only need totals (in bold) for the row for columns D,E,F. The
corresponding row for Column C can be blank.e.g.

Apple Fruit 100 200 200 100
Apple Fruit 100 200 200 100
Apple Fruit 400 400 200 (should be bold)

Look forward to hearing from you.

Cheers Sharon

 

[Per Jessen]

Hi Sharon

Thanks for your reply.

Change the last line before "End Sub" to this:

Range(Cells(counter + 1, "D"), Cells(counter + 1, "F")).Font.Bold = True

Regards,
Per

 

[Shazza]

Hi Per,

I have added the line as suggested and this has made the line bold but not
given me totals in those columns. I need the totals only in Column D,E and F
as suggested below.

Apple Fruit 100 200 200 100
Apple Fruit 100 200 200 100
Apple Fruit 400 400 200 (should be bold and total)

Hoping you can assist again.

Thanks Sharon

 

[Per Jessen]

Hi Sharon

Ok, I obviously didn't read your last post carefully enough :-(

Try this:

Dim FirstRow As Long
Dim TargetCol As String
Dim SumCol As String
Dim LastRow As Long
Dim counter As Long
Dim StartSum As Long
Dim EndSum As Long

Sub InsertRow_Total()

FirstRow = 2 'Assume headers in row 1
TargetCol = "A"
SumCol = "D"
counter = FirstRow
LastRow = Cells(Rows.Count, TargetCol).End(xlUp).Row
StartSum = FirstRow

Do
If Cells(counter, TargetCol).Value <> Cells(counter + 1,
TargetCol).Value Then
LastRow = LastRow + 1
Rows(counter + 1).Insert
Cells(counter, TargetCol).Resize(1, 2).Copy Cells(counter + 1,
TargetCol)
EndSum = counter
Cells(counter + 1, SumCol).Formula = "=sum(D" & StartSum & "" &
EndSum & ")"
Cells(counter + 1, SumCol).AutoFill Destination:=Range(Cells(counter
+ 1, SumCol), _
Cells(counter + 1, SumCol).Offset(0, 2)), Type:=xlFillDefault
Rows(counter + 1).Font.Bold = True
counter = counter + 2
StartSum = counter
Else
counter = counter + 1
End If
Loop Until counter = LastRow
Cells(counter, TargetCol).Resize(1, 2).Copy Cells(counter + 1, TargetCol)
Cells(counter + 1, SumCol).Formula = "=sum(D" & StartSum & "" & counter &
")"
Cells(counter + 1, SumCol).AutoFill Destination:=Range(Cells(counter + 1,
SumCol), _
Cells(counter + 1, SumCol).Offset(0, 2)), Type:=xlFillDefault
Rows(counter + 1).Font.Bold = True
End Sub

Regards,
Per

 

[Shazza]

Thanks Per, it works like a dream.

Sharon

Hi Sharon

Ok, I obviously didn't read your last post carefully enough :-(

Try this:

Dim FirstRow As Long
Dim TargetCol As String
Dim SumCol As String
Dim LastRow As Long
Dim counter As Long
Dim StartSum As Long
Dim EndSum As Long

Sub InsertRow_Total()

FirstRow = 2 'Assume headers in row 1
TargetCol = "A"
SumCol = "D"
counter = FirstRow
LastRow = Cells(Rows.Count, TargetCol).End(xlUp).Row
StartSum = FirstRow

Do
If Cells(counter, TargetCol).Value <> Cells(counter + 1,
TargetCol).Value Then
LastRow = LastRow + 1
Rows(counter + 1).Insert
Cells(counter, TargetCol).Resize(1, 2).Copy Cells(counter + 1,
TargetCol)
EndSum = counter
Cells(counter + 1, SumCol).Formula = "=sum(D" & StartSum & "" &
EndSum & ")"
Cells(counter + 1, SumCol).AutoFill Destination:=Range(Cells(counter
+ 1, SumCol), _
Cells(counter + 1, SumCol).Offset(0, 2)), Type:=xlFillDefault
Rows(counter + 1).Font.Bold = True
counter = counter + 2
StartSum = counter
Else
counter = counter + 1
End If
Loop Until counter = LastRow
Cells(counter, TargetCol).Resize(1, 2).Copy Cells(counter + 1, TargetCol)
Cells(counter + 1, SumCol).Formula = "=sum(D" & StartSum & "" & counter &
")"
Cells(counter + 1, SumCol).AutoFill Destination:=Range(Cells(counter + 1,
SumCol), _
Cells(counter + 1, SumCol).Offset(0, 2)), Type:=xlFillDefault
Rows(counter + 1).Font.Bold = True
End Sub

Regards,
Per