Glad you found a solution. I'm afraid I was getting a bit too ambitious. I was going for 'can be used anywhere' rather than just a solution to your existing situation. And I've only had a few minutes before work to pick at it.
Here's what I came up with.
Public Sub Insert_Rows_Below_SubTotals()
'======================================================================================================================
' Declarations
'======================================================================================================================
'**********************************************************************************************************************
' Variable Declarations
'**********************************************************************************************************************
'Booleans
Dim bolFound As Boolean
'Counters
Dim lngCount1 As Long
'Ranges
Dim rngSubTotals As Range
Dim rngHeaders As Range
Dim c As Range
Dim c1 As Range
Dim rngSubTotalSection As Range
'Temps
Dim lngRowsToInsert As Long
Dim bytStartColumn As Byte
Dim bytEndColumn As Byte
Dim bytTotalsColumn As Byte
Dim lngStartRow As Long
Dim lngEndRow As Long
'======================================================================================================================
' Code
'======================================================================================================================
'Get the number of Rows to Insert from the user
lngRowsToInsert = _
Application.InputBox("How many Rows do you want to insert below each subtotal?", _
"Number of Rows", 1)
'Find the column with the 'Totals'
With ActiveSheet.UsedRange
Set c = .Find(What:="Total", LookIn:=xlValues, LookAt:=xlPart)
bolFound = False
While Not bolFound
If Not c Is Nothing Then
If Right(c.Value, 5) = "Total" Then
bytTotalsColumn = c.Column
bolFound = True
Else
Set c1 = .FindNext(c)
If Not c1 Is Nothing Then
Set c = c1
Else
MsgBox "No totals found"
Exit Sub
End If
End If
Else
MsgBox "No totals found"
Exit Sub
End If
Wend
End With
'Set the SubtTotals Range
With ActiveSheet
Set rngSubTotals = .Range(.Cells(.UsedRange.Row, bytTotalsColumn), _
.Cells((.UsedRange.Row + .UsedRange.Rows.Count - 1), bytTotalsColumn))
End With
'Get the Header range from the user
Set rngHeaders = _
Application.InputBox("Select the Headers to be repeated for each SubTotal Range", _
"User Input Required", Type:=8)
'Assuming the header range encompasses the columns to be formatted, set the left and right columns
'for the formatting.
bytStartColumn = rngHeaders.Column
bytEndColumn = bytStartColumn + rngHeaders.Columns.Count - 1
'Loop through range looking for the word "Total"
For Each c In ActiveSheet.UsedRange
If Right(c.Value, 5) = "Total" Then
c.Offset(1, 0).EntireRow.Resize(lngRowsToInsert).Insert shift:=xlDown
Else
End If
Next c
rngHeaders.Copy
'Set Headers
For Each c In ActiveSheet.UsedRange
If Right(c.Value, 5) = "Total" Then
c.Offset(lngRowsToInsert, lngStartRow).PasteSpecial xlPasteAll
Else
End If
Next c
'Get the start of the first section
lngStartRow = rngHeaders.Row
'Find the first Total to identify the end of the range
With rngSubTotals
Set c = .Find(What:="Total", LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
Else
MsgBox "Couldn't find the end of the section."
Exit Sub
End If
Set c1 = c
Do
'Create section to format
With ActiveSheet
Set rngSubTotalSection = .Range(.Cells(lngStartRow, bytStartColumn), _
.Cells(c1.Row, bytEndColumn))
End With
'Format section
With rngSubTotalSection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 47
End With
With rngSubTotalSection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 47
End With
With rngSubTotalSection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 47
End With
With rngSubTotalSection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 47
End With
lngStartRow = c1.Row + lngRowsToInsert
Set c1 = .FindNext(c1)
Loop Until c1.Address = c.Address
End With
'======================================================================================================================
' Clean Up
'======================================================================================================================
Set rngSubTotals = Nothing
Set rngHeaders = Nothing
Set c = Nothing
Set c1 = Nothing
Set rngSubTotalSection = Nothing
End Sub
This should handle your formatting requirement. Note that if you want different formatting, you can simply record formatting one of the sections the way you want it, and then use that to replace the formatting code I've got.
David B.