Search Columns For Change, Insert Blank Rows, and Sum Differen
 

Try this, with the sheet with the data being the active one.

Sub InsertRowsSums()
Dim iRow As Long
Dim iFirst As Long
Dim aColA As String
Dim aColB As String
iRow = 2
iFirst = 2
aColA = Cells(iRow, 1)
aColB = Cells(iRow, 2)
Do
iRow = iRow + 1
If Cells(iRow, 1) < aColA Or Cells(iRow, 2) < aColB Then
Rows(iRow & ":" & iRow + 1).Insert Shift:=xlDown
str1 = "D" & iFirst & ":D" & iRow - 1
Cells(iRow, 4).Formula = "=Sum(" & str1 & ")"
Cells(iRow, 4).Copy Range(Cells(iRow, 5), Cells(iRow, 7))
iRow = iRow + 2
iFirst = iRow
aColA = Cells(iRow, 1)
aColB = Cells(iRow, 2)
End If
Loop Until Cells(iRow, 1) = ""
End Sub

Hth,
Merjet

Search Columns For Change, Insert Blank Rows, and Sum Differen
 

Thanks for the help! This will make things much easier.

"merjet" wrote:

Try this, with the sheet with the data being the active one.

Sub InsertRowsSums()
Dim iRow As Long
Dim iFirst As Long
Dim aColA As String
Dim aColB As String
iRow = 2
iFirst = 2
aColA = Cells(iRow, 1)
aColB = Cells(iRow, 2)
Do
iRow = iRow + 1
If Cells(iRow, 1) < aColA Or Cells(iRow, 2) < aColB Then
Rows(iRow & ":" & iRow + 1).Insert Shift:=xlDown
str1 = "D" & iFirst & ":D" & iRow - 1
Cells(iRow, 4).Formula = "=Sum(" & str1 & ")"
Cells(iRow, 4).Copy Range(Cells(iRow, 5), Cells(iRow, 7))
iRow = iRow + 2
iFirst = iRow
aColA = Cells(iRow, 1)
aColB = Cells(iRow, 2)
End If
Loop Until Cells(iRow, 1) = ""
End Sub

Hth,
Merjet