Get a list index of print page ranges [solved]

B

BrianB

Well-known Member
Joined
Feb 17, 2003
Messages
8,127
There is a frequent need to get a list of ranges for printed pages - such as when making an index to items in a worksheet. This macro makes an array of references in page number order.

The following message shows a way of using the array to find specific items in the worksheet and get the page numbers. It uses page break positions.

There is a caveat that it is necessary to check the output. Best way is to check the page number of an item in an end page. Printing still does not seem to be an exact science. For example, its seems necessary to do a PrintPreview at the beginning of the macro to set the page breaks. You will see the note concerning a bug if the Active Cell is in the page range.

Code: 
'=============================================================================
'- GET AN INDEX LIST OF PRINT PAGE RANGES
'- 3 dimension array : Page Top Left cell. Bottom Right cell. Page range.
'=============================================================================
'*****************************************************************************
'- *** PRINTING IS NOT AN EXACT SCIENCE                                    ***
'- *** SEEMS NECESSARY TO PREVIEW THE DATA SHEET FIRST TO SET PAGE BREAKS  ***
'- ***  CHECK AN END PAGE ITEM IN THE FINAL OUTPUT WITH PRINTPREVIEW       ***
'*****************************************************************************
'- **Overcomes Excel bug that gives an error message if the ActiveCell
'-   is within the print range.  Ref. [URL]http://support.microsoft.com/kb/210663[/URL]
'- Checks to see if there is an existing Print_Area set
'- Different methods for print order Down/Over or Over/Down
'- Brian Baulsom March 2010
'=============================================================================
Option Base 1
'=============================================================================
Public PagesArray()     ' PUBLIC ARRAY CAN BE ACCESSED BY OTHER CODE MODULES
'                       ' Run from the other code module
'===========================================================================
Dim ws As Worksheet
Dim AllSheetsRange As Variant   ' set to "Print_Area" reference if it exists
Dim PageNumber As Long
Dim LastCell As Range
Dim LastRow As Long
Dim LastCol As Integer
Dim PageCount As Integer
'- Horizontal PB
Dim HPBnumber As Integer
Dim HPBcount As Integer
Dim HPB As Object
'- Vertical PB
Dim VPBnumber As Integer
Dim VPBcount As Integer
Dim VPB As Object
'- Single page reference
Dim TopRow As Long
Dim TopCol As Integer
Dim BottomRow As Long
Dim BottomCol As Integer
'- array for pages
Dim PageSetupOrder As Long  ' Down/Over or Over/Down
Dim NewSet As Boolean       ' Set of pages depending on the print order
Dim rsp
'=============================================================================
'-  MAIN ROUTINE
'=============================================================================
Sub PAGE_RANGES_TO_ARRAY()
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    '- PRINT RANGE
    Set ws = Worksheets("Data")
    On Error Resume Next
    '=======================================
    Set AllSheetsRange = ws.Range("Print_Area") ' SEE IF PRINT RANGE EXISTS
    '=======================================
    If Err.Number <> 0 Then         ' THE RANGE DOES NOT EXIST
        '---------------------------------------------------------------------
        '- GET LAST *REAL* USED ROW & COLUMN (used in case there are empty cells at the end)
        '- ROW
        Set LastCell = ws.Cells.Find(What:="*", After:=Range("IV65536"), _
            LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
        LastRow = LastCell.Row
        '- COLUMN
        Set LastCell = ws.Cells.Find(What:="*", After:=Range("IV65536"), _
            LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
        LastCol = LastCell.Column
        '---------------------------------------------------------------------
    Else
        LastRow = AllSheetsRange.Rows.Count
        LastCol = AllSheetsRange.Columns.Count
    End If
    '-------------------------------------------------------------------------
    Err.Clear
    On Error GoTo 0         ' reset to normal error trapping
    '-------------------------------------------------------------------------
    '- PAGES & PAGE BREAKS
     With ws
        .Activate     ' activate sheet for Excel 4 Macro & cell Activate
        .PrintPreview
        PageCount = Application.ExecuteExcel4Macro("GET.DOCUMENT(50)")
        '---------------------------------------------------------------------
        '- ACTIVATE A CELL OUTSIDE THE PRINT AREA TO STOP EXCEL ERROR MESSAGE
        .Range("A65536").Activate
        '---------------------------------------------------------------------
        PageSetupOrder = .PageSetup.Order         ' Down/Over =1. Over/Down=2
        HPBcount = .HPageBreaks.Count
        VPBcount = .VPageBreaks.Count
    End With
    '-------------------------------------------------------------------------
    ReDim PagesArray(PageCount, 3)
    '*************************************************************************
    ' SHOW 'PROPERTIES' MSGBOX FOR TESTING (remove comments ')
'    ShowPropertiesMsg
'    If rsp = vbCancel Then GoTo GetOut
    '*************************************************************************
    '=========================================================================
    '- DIFFERENT METHODS DEPENDING ON PRINT ORDER
    '=========================================================================
    If PageSetupOrder = 1 Or VPBcount = 0 Then
        DOWN_OVER
    Else
        OVER_DOWN
    End If
    '-------------------------------------------------------------------------
    '- GO TO TOP OF MAIN SHEET
    Application.Goto reference:=ws.Range("A1"), Scroll:=True
    '*************************************************************************
    '- READ THE ARRAY TO WORKSHEET FOR CHECKING (remove comment ')
'    READ_ARRAY      ' SUBROUTINE reads the array to a worksheet
    '*************************************************************************
    Application.ScreenUpdating = True
    'MsgBox ("Array done")
GetOut:
    Application.StatusBar = False
End Sub
'=========== END OF MAIN ROUTINE =============================================
'=============================================================================
'- SUBROUTINE : PRINT ORDER OVER/DOWN
'=============================================================================
Private Sub OVER_DOWN()
    PageNumber = 1
    While PageNumber <= PageCount
        Application.StatusBar = PageNumber & "/" & PageCount
        '---------------------------------------------------------------------
        '- PAGE 1
        If PageNumber = 1 Then
            NewSet = False
            '-----------------------------------------------------------------
            '- row
            HPBnumber = 0
            TopRow = AllSheetsRange.Cells(1, 1).Row
            BottomRow = ws.HPageBreaks(1).Location.Row - 1
            '-----------------------------------------------------------------
            '- column
            TopCol = AllSheetsRange.Cells(1, 1).Column
            VPBnumber = 1
            BottomCol = ws.VPageBreaks(1).Location.Column - 1
        '---------------------------------------------------------------------
        '- NEW SET (VERTICAL PAGEBREAK = 1)
        ElseIf NewSet = True Then
            TopCol = AllSheetsRange.Cells(1, 1).Column
            BottomCol = ws.VPageBreaks(1).Location.Column - 1
            NewSet = False
        '---------------------------------------------------------------------
        '- LAST VERTICAL PAGEBREAK -> NEXT HORIZONTAL PAGEBREAK (New Set)
        ElseIf VPBnumber = VPBcount Then
            TopCol = ws.VPageBreaks(VPBnumber).Location.Column
            BottomCol = LastCol
            VPBnumber = 1
            NewSet = True       ' ************* CHANGE BELOW
        '---------------------------------------------------------------------
        '- INTERMEDIATE PAGE - Next Vertical Page Break
        Else
            TopCol = ws.VPageBreaks(VPBnumber).Location.Column
            BottomCol = ws.VPageBreaks(VPBnumber + 1).Location.Column - 1
            VPBnumber = VPBnumber + 1
        End If
        '---------------------------------------------------------------------
        '-  PAGE REFERENCES TO THE ARRAY
        PagesArray(PageNumber, 1) = Cells(TopRow, TopCol).Address
        PagesArray(PageNumber, 2) = Cells(BottomRow, BottomCol).Address
        PagesArray(PageNumber, 3) = PagesArray(PageNumber, 1) & ":" & PagesArray(PageNumber, 2)
        PageNumber = PageNumber + 1
        '=====================================================================
        '- END OF PRINT SET (NewSet = True at last VERTICAL Page break above)
        '- New HORIZONTAL ROW & back to the LEFT
        '=====================================================================
        If PageNumber < PageCount And NewSet Then
            HPBnumber = HPBnumber + 1
            TopRow = BottomRow + 1
            If HPBnumber < HPBcount Then
                BottomRow = ws.HPageBreaks(HPBnumber + 1).Location.Row - 1
            Else
                BottomRow = LastRow
            End If
        End If
        '---------------------------------------------------------------------
    Wend
End Sub
'=============================================================================
'- SUBROUTINE : PRINT ORDER DOWN/OVER
'=============================================================================
Private Sub DOWN_OVER()
    PageNumber = 1
    While PageNumber <= PageCount
        Application.StatusBar = PageNumber & "/" & PageCount
        '---------------------------------------------------------------------
        '- PAGE 1
        If PageNumber = 1 Then
            NewSet = False
            HPBnumber = 1
            VPBnumber = 0
            TopRow = AllSheetsRange.Cells(1, 1).Row
            BottomRow = ws.HPageBreaks(1).Location.Row - 1
            TopCol = AllSheetsRange.Cells(1, 1).Column
            If VPBcount = 0 Then
                BottomCol = LastCol
            Else
                BottomCol = ws.VPageBreaks(1).Location.Column - 1
            End If
        '---------------------------------------------------------------------
        '- NEW SET OF VERTICAL PAGES
        ElseIf NewSet = True Then
            HPBnumber = 1
            TopRow = AllSheetsRange.Cells(1, 1).Row
            BottomRow = ws.HPageBreaks(1).Location.Row - 1
            NewSet = False
        '---------------------------------------------------------------------
        '- LAST HORIZONTAL PAGEBREAK -> NEXT VERTICAL PAGEBREAK (New Set)
        ElseIf HPBnumber = HPBcount Then
            TopRow = ws.HPageBreaks(HPBnumber).Location.Row
            BottomRow = LastRow
            NewSet = True
        '---------------------------------------------------------------------
        '- INTERMEDIATE PAGE
        Else
            TopRow = ws.HPageBreaks(HPBnumber).Location.Row
            BottomRow = ws.HPageBreaks(HPBnumber + 1).Location.Row - 1
            HPBnumber = HPBnumber + 1
        End If
        '---------------------------------------------------------------------
        '-  PAGE REFERENCES TO THE ARRAY
        PagesArray(PageNumber, 1) = Cells(TopRow, TopCol).Address
        PagesArray(PageNumber, 2) = Cells(BottomRow, BottomCol).Address
        PagesArray(PageNumber, 3) = PagesArray(PageNumber, 1) & ":" & PagesArray(PageNumber, 2)
        PageNumber = PageNumber + 1
        '=====================================================================
        '- END OF PRINT SET (NewSet = True at last horizontal Page break above)
        '- NEW VERTICAL PAGE BREAK
        '=====================================================================
        If PageNumber < PageCount And NewSet Then
            VPBnumber = VPBnumber + 1
            If VPBnumber < VPBcount Then
                TopCol = BottomCol + 1
                BottomCol = ws.VPageBreaks(VPBnumber + 1).Location.Column - 1
            Else
                TopCol = ws.VPageBreaks(VPBcount).Location.Column
                BottomCol = LastCol
            End If
        End If
        '---------------------------------------------------------------------
    Wend
End Sub
'========== EOP ==============================================================
'=============================================================================
'- SUBROUTINE : READ THE ARRAY TO WORKSHEET "ReadArray"
'-   makes a new sheet if it does not exist
'=============================================================================
Private Sub READ_ARRAY()
    With Worksheets("ReadArray")
        .Range("A:D").ClearContents
        .Range("A1:D1").Value = Array("Page", "Top Left", "Bottom Right", "Range")
        Application.ScreenUpdating = False
        '---------------------------------------------------------------------
        '- ARRAY DATA TO WORKSHEET
        For PageNumber = 1 To UBound(PagesArray)        '        pagecount
            .Cells(PageNumber + 1, 1).Value = PageNumber
            .Cells(PageNumber + 1, 2).Value = PagesArray(PageNumber, 1)
            .Cells(PageNumber + 1, 3).Value = PagesArray(PageNumber, 2)
            .Cells(PageNumber + 1, 4).Value = PagesArray(PageNumber, 3)
        Next
        '---------------------------------------------------------------------
        .Activate
    End With
End Sub
'========= EOP ===============================================================
 
'=============================================================================
'- SUBROUTINE : MESSAGE BOX SHEET PROPERTIES
'=============================================================================
Private Sub ShowPropertiesMsg()
    Dim MyMsg As String
    MyMsg = "Total Pages      :  " & PageCount & vbCr _
            & "Horizontal PB  :  " & HPBcount & vbCr _
            & "Vertical PB       :  " & VPBcount & vbCr _
            & "Last Row          :  " & LastRow & vbCr _
            & "Last Column   :  " & LastCol & vbCr _
            & "Print Order      :  " & IIf(PageSetupOrder = 1, "Down/Over", "Over/Down")
    rsp = MsgBox(MyMsg, vbOKCancel, "Sheet  : '" & ws.Name & "'")
End Sub
'==============================================================================
 
Sort by date Sort by votes
Here is a way of using the array.
Code: 
'=============================================================================
'- FIND PRINTER PAGE NUMBERS OF DATA IN A WORKSHEET
'- COULD BE USED TO MAKE AN INDEX SHEET
'- Runs macro 'PAGE_RANGES_TO_ARRAY' in external code module first
'=============================================================================
'*****************************************************************************
'- *** PRINTING IS NOT AN EXACT SCIENCE                                    ***
'- *** SEEMS NECESSARY TO PREVIEW THE DATA SHEET FIRST TO SET PAGE BREAKS  ***
'- ***  CHECK AN END PAGE ITEM IN THE FINAL OUTPUT WITH PRINTPREVIEW       ***
'*****************************************************************************
'- Progress shown in the status bar.
'- Uses Public Array 'PagesArray' in the external module
'- Items to find are in a worksheet list column A
'- Looks for multiple matches
'- Page numbers are put into column B onwards
'- Can speed things up by limiting the columns searched ........
'- ...  (eg. change 'With DataSheet.Cells' to 'With Datasheet.Range("A:A")'
'- Brian Baulsom March 2010
'=============================================================================
Option Base 1
Sub GET_PAGE_NUMBERS()
    Dim DataSheet As Worksheet
    Dim FindValue As String
    Dim TargetSheet As Worksheet
    Dim ToRow As Long
    Dim ToColumn As Integer
    Dim FoundCell As Range
    Dim PageRange As Range
    Dim PageNumber As Integer
    Dim FirstAddress As String
    Dim p, isect
    '-------------------------------------------------------------------------
    '- INITIALISE THE ARRAY
    Set DataSheet = Worksheets("Data")          ' source sheet
    Set TargetSheet = Worksheets("ReadArray")   ' items to find
    Application.Run ("PAGE_RANGES_TO_ARRAY")    ' EXTERNAL CODE MODULE
    '-------------------------------------------------------------------------
    '- LOOP LIST OF DATA ITEMS TO FIND
    For ToRow = 26 To 31
        TargetSheet.Range("B" & ToRow & ":O" & ToRow).ClearContents 'CLEAR DATA
        FindValue = TargetSheet.Cells(ToRow, 1).Value
        Application.StatusBar = "  Searchin for " & FindValue
        ToColumn = 2
        '-----------------------------------------------------------------
        '- FIND
        With DataSheet.Cells
            Set FoundCell = .Find(What:=FindValue, _
                After:=.Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, _
                SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
                MatchCase:=False)
            If FoundCell Is Nothing Then
                PageNumber = 0
            Else
                FirstAddress = FoundCell.Address
                Do
                    '======================================================
                    '- LOOK FOR PAGE CONTAINING THE FOUND CELL
                    For PageNumber = 1 To UBound(PagesArray)
                        Set PageRange = .Range(PagesArray(PageNumber, 3))
                        Set isect = Application.Intersect(FoundCell, PageRange)
                        '===================================================
                        '- ITEM FOUND - PAGE NUMBER TO SHEET
                        If Not isect Is Nothing Then
                            TargetSheet.Cells(ToRow, ToColumn).Value = PageNumber
                            ToColumn = ToColumn + 1
                            Exit For
                        End If
                        '===================================================
                    Next
                    '-------------------------------------------------------
                    Set FoundCell = .FindNext(FoundCell)
                    '-------------------------------------------------------
                Loop While Not FoundCell Is Nothing And FoundCell.Address <> FirstAddress
            End If
        End With
        '------------------------------------------------------------------------
    Next
    '----------------------------------------------------------------------------
    TargetSheet.Activate
    MsgBox ("Done")
    Application.StatusBar = False
End Sub
'========== eop =================================================================
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Question Question
Macro Page Preview
Replies
3
Views
232
Micron
M
A
  • Question Question
VBA for setting up the printing pages per sheet
Replies
0
Views
757
Aurum1
A
B
  • Question Question
VBA exports worksheet from XLSM to XLXS matching all source properties doesn't keep print area
Replies
0
Views
214
brentcole
B
F
  • Solved
Page Breaks and Subscript out of Range
Replies
1
Views
825
Farscape2020
F
N
  • Solved
Script to determine number of pages to save/print "Microsoft Print to PDF"
Replies
3
Views
858
noveske
N

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top