VBA code to set page headers in a special way

[kelly mort]

My table is like this:

Range(“A3:J” & lr)

Where lr is the last used row in column B

So, column B contain names which has associated categories in column C.

At the end of each category in column C, there is a “SUB-TOTAL” string in column B.

Now here is what I want to do:
When I get to a “SUB-TOTAL” string in column B, I want to have three (3) blank rows inserted below the “SUB-TOTAL” string.

Then after that I want to copy the contents of the range A1:J2 and paste it at the second and third rows of the the blank rows I have just inserted(that is to create a header for the next category)

*****The first blank row is there to separate one category from another******

Then I repeat the copy and pasting of A1:J2 for each SUB-TOTAL that I come across in the column B.

FYI:
The Range A1:J1 is merged.

I also want to apply the row heights of the source to the destination.

I am using this approach because I want to have multiple categories on a sheet when I print out and still have my headers for each category.

Can someone please help me out with the code for that?

Thanks in advance.

 

[DanteAmor]

The following uses the Find method to locate only the cells with the text "Sub-total", that makes it faster than going row by row.

Sub InsertHeader()
  Dim r As Range, f As Range, cell As String
  Application.ScreenUpdating = False
  
  Set f = Range("B:B").Find("SUB-TOTAL", , xlValues, xlWhole, xlByRows, xlPrevious, False)
  If Not f Is Nothing Then
    Set r = Range("B3:B" & f.Row - 1)
    Set f = r.Find("SUB-TOTAL", , xlValues, xlWhole, xlByRows, xlNext, False)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        f.Offset(1).Resize(3).EntireRow.Insert
        Range("A1:J2").Copy f.Offset(2, -1)
        Set f = r.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell
    End If
  End If
  Application.ScreenUpdating = True
End Sub

 

[kelly mort]

@DanteAmor
It worked so great.

One or two touches to the code and all be great:
1. I want to remove the background fill from the empty row.
2. I remove all vertical borders on the empty row (so they appear separated from each other)

 

[DanteAmor]

Add this line:

f.Offset(1).Resize(3).EntireRow.Clear

Sub InsertHeader()
  Dim r As Range, f As Range, cell As String
  Application.ScreenUpdating = False
  
  Set f = Range("B:B").Find("SUB-TOTAL", , xlValues, xlWhole, xlByRows, xlPrevious, False)
  If Not f Is Nothing Then
    Set r = Range("B3:B" & f.Row - 1)
    Set f = r.Find("SUB-TOTAL", , xlValues, xlWhole, xlByRows, xlNext, False)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        f.Offset(1).Resize(3).EntireRow.Insert
        f.Offset(1).Resize(3).EntireRow.Clear
        Range("A1:J2").Copy f.Offset(2, -1)
        Set f = r.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell
    End If
  End If
  Application.ScreenUpdating = True
End Sub

 

[kelly mort]

This is so amazing.
I am very grateful.

Have a great moment

 

[kelly mort]

I also want to apply the row heights of the source to the destination.

Hello @DanteAmor
How do I apply the copied header’s row heights to pasted ranges?

 

[DanteAmor]

There it goes

Sub InsertHeader()
  Dim r As Range, f As Range, cell As String
  Application.ScreenUpdating = False
  
  Set f = Range("B:B").Find("SUB-TOTAL", , xlValues, xlWhole, xlByRows, xlPrevious, False)
  If Not f Is Nothing Then
    Set r = Range("B3:B" & f.Row - 1)
    Set f = r.Find("SUB-TOTAL", , xlValues, xlWhole, xlByRows, xlNext, False)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        f.Offset(1).Resize(3).EntireRow.Insert
        f.Offset(1).Resize(3).EntireRow.Clear
        Range("A1:J2").Copy f.Offset(2, -1)
        f.Offset(2).RowHeight = Range("A1").RowHeight
        f.Offset(3).RowHeight = Range("A2").RowHeight
        Set f = r.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell
    End If
  End If
  Application.ScreenUpdating = True
End Sub