VBA/Macro to detect a heading at the bottom of a page and create a page break

[jdodz]

Hi everyone

First up, sorry about the long post, I thought I would write down a bit of a background of how the code works etc. before I post my problem.
I have created an Interview Guide Builder that will be used by people to choose from a list of questions and write some of their own to ask candidates who are applying for jobs.
I have one macro within this document, titled “GenerateGuide”. It generates a pdf Interview Guide that the interviewer will take with them the meeting.

Sub GenerateGuide()
'
' GenerateGuide Macro
'

'
    Sheets("Interview Guide Builder").Select
    Sheets("Interview Guide").Visible = True
    Sheets("Interview Guide").Select
    Sheets("Interview Guide").Copy After:=Sheets(2)
    Sheets("Interview Guide").Select
    ActiveWindow.SelectedSheets.Visible = False
    Columns("B:B").Select
    Selection.AutoFilter
    ActiveSheet.Range("$B:$B").AutoFilter Field:=1, Criteria1:="0"
    Cells.Select
    Selection.Delete Shift:=xlUp
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
    Range("C2").Select
    Selection.Copy
    Range("H2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("B2").Select
    ActiveCell.FormulaR1C1 = _
        "=""Interview Guide ""&RC[6]&"" ""&TEXT(NOW(),""ddmmyyyy hhmm"")"
    Range("B2").Select
    Selection.Copy
    Range("G2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Environ("USERPROFILE") & "\Desktop\" & Range("G2").Value & ".pdf", _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=True
    Application.DisplayAlerts = False
    Sheets("Interview Guide (2)").Select
    ActiveWindow.SelectedSheets.Delete
    Application.DisplayAlerts = True
    Sheets("Interview Guide Builder").Select
End Sub

The way I have set it up to run is:

- The user selects / writes the question and presses the “Generate Guide” button which starts the macro
- All questions appear in a hidden sheet titled “Interview Guide” and have a formula in column B which decides whether the question has been selected or not.
- The macro unhides the hidden “Interview Guide” worksheet and makes a copy of it. The original “Interview Guide” is then re-hidden.
- It then filters columns B to only show those which were not selected. It then deletes these rows.
- Column B is then deleted.
- To create an individual title for each time the Guide is generated, the macro then creates the title which ends up in cell G2.
- The guide is then published as a PDF (as I can’t copy and paste into word and keep the formatting nice).
- The duplicate worksheet is then deleted. End macro.

The macro itself is probably a bit clunky , but I’m a bit of a novice and so I’m happy with what it can do so far (if anyone has whiz bang ideas to make it run smoother, by all means let me know!!).

What I am having trouble with is this… In the example I have attached, you will see that I have pre-selected some questions etc to help show my issue.
When I run the macro and it publishes in pdf, you will notice some of the grey headings eg. “Managing Services” and “Leads and Empowers” sit at the bottom of two pages and the questions meant for that section are then on the next page. This will change depending on the questions selected by the user though, but happens quite frequently. What I want is that if a new heading comes up, then the first question under that heading appears straight after it (ie. On the same page) – does that make sense?
I’ve tried resizing rows etc, but no luck.

I have a few thoughts on how this could be fixed, but no idea how to do it:

- As part of the macro, if it notices a heading at the bottom of a page, it creates a page break to push it over to the next page (probably preferred option).
- A word document is created (keeping the formatting as it is set up in the excel file) and the user can press enter to push the headings down to the next page themselves if they notice it.

Any ideas?

Cheers
Jess.

[jaslake]

Hi jdodz

I won't guarantee this Code will work universally but it appears to work on your Sample File.

What it's doing is identifying Line Number of each Page Break in the Document. It then looks at each of these Page Break Rows...if the Cell above it (in Column B) has a Color Index of Grey(15), the Code inserts a Manual Page Break.

I've also taken the liberty of streamlining the Code a bit

if anyone has whiz bang ideas to make it run smoother, by all means let me know

Try it...let me know of issues...

Option Explicit
Sub GenerateGuide()
    Dim lPages As Long
    Dim cel As Range
    With Sheets("Interview Guide")
        .Visible = True
        .Copy After:=Sheets(2)
        .Visible = False
    End With

    With ActiveSheet
        .Range("$B:$B").AutoFilter Field:=1, Criteria1:="0"
        .Range("$B:$B").SpecialCells(xlCellTypeVisible).Delete shift:=xlUp
        .Columns("B:B").Delete shift:=xlToLeft
        .Range("H2").Value = .Range("C2").Value
        .Range("B2").FormulaR1C1 = _
                "=""Interview Guide ""&RC[6]&"" ""&TEXT(NOW(),""ddmmyyyy hhmm"")"
        .Range("G2").Value = .Range("B2").Value

        lPages = .HPageBreaks.Count + 1

        .Names.Add Name:="HPBreaks", RefersTo:="=GET.DOCUMENT(64)"
        .Cells(1, "L").Resize(lPages, 1).Formula = "=INDEX(HPBreaks,ROW())"

        For Each cel In .Range("L1").Resize(lPages, 1)
            If .Cells(cel.Value - 1, "B").Interior.ColorIndex = 15 Then
                .HPageBreaks.Add Before:=Cells(cel.Value - 1, "B")
            End If
        Next cel

        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=Environ("USERPROFILE") & "\Desktop\" & Range("G2").Value & ".pdf", _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
                :=False, OpenAfterPublish:=True
    End With
    Application.DisplayAlerts = False
    Sheets("Interview Guide (2)").Delete
    Application.DisplayAlerts = True
    Sheets("Interview Guide Builder").Select
End Sub

[natefarm]

I had already developed this code when I came back and saw that jaslake had replied, but I thought I might as well post it too. It goes through "Part 3" and adds page breaks as needed, based on the sum of the row sizes in each section.

I also cleaned up the existing code as you had requested. The macro recorder puts in a lot of unneeded code. It all seemed to work when I ran it. Have fun!

Sub GenerateGuide()
    Application.ScreenUpdating = False
    Sheets("Interview Guide").Copy After:=Sheets(2)
    Sheets("Interview Guide (2)").Visible = True
    Sheets("Interview Guide (2)").Select

    Columns("B:B").AutoFilter Field:=1, Criteria1:="0"
    Cells.Delete Shift:=xlUp
    Columns("B:B").Delete Shift:=xlToLeft
    Range("C2").Copy
    Range("H2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("B2").FormulaR1C1 = _
        "=""Interview Guide ""&RC[6]&"" ""&TEXT(NOW(),""ddmmyyyy hhmm"")"
    Range("B2").Copy
    Range("G2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

    Call AddPageBreaks

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Environ("USERPROFILE") & "\Desktop\" & Range("G2").Value & ".pdf", _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=True
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True
End Sub

Sub AddPageBreaks()
Dim Rw1 As Long, Rw2 As Long, EndRw As Long

    Rw1 = 1 ' In case of error below, process full sheet
    EndRw = Range("B" & Rows.Count).End(xlUp).Row
    On Error Resume Next
    Rw1 = ActiveSheet.HPageBreaks(1).Location.Row ' Find the first section
    EndRw = ActiveSheet.Cells.Find(what:="Part 4", lookat:=xlPart).Row ' Quit after Part 3
    On Error GoTo 0
    Rw2 = Cells(Rw1, 2).End(xlDown).Row + 2 ' Find next section

    Do Until Rw2 > EndRw
        If Rows(Rw1 & ":" & Rw2 + 1).Height > 781 Then
            ActiveSheet.HPageBreaks.Add Before:=Cells(Rw2, 1)
            Rw1 = Rw2
        End If
        Rw2 = Cells(Rw2, 2).End(xlDown).Row + 2 ' Find next section
    Loop
End Sub

[jdodz]

Hi John and Natefarm

Both appear to work perfectly!
I'm just getting my team to test it with me (so that we can get a bunch of combinations to check the headings are pushing down where needed), but thank you so much in advance!
I'll let you know if there are any issues, but at this point, I'm happy to mark as solved.

Cheers
Jess.

[jaslake]

You're welcome...glad I could help. Thanks for the Rep.

[natefarm]

Dittos from me.