Returning the page range addresses from a worksheet

The custom function below can be used to return a collection of the page ranges in a worksheet. This can be useful when you need to be able to target a spesific page (e.g. when formatting or copying).

Function GetPageRangeAddresses(ws As Worksheet) As Collection
' returns a collection containing the page range addresses of a worksheet
Dim h(1 To 2) As Integer, v(1 To 2) As Integer
Dim r(1 To 2) As Long, c(1 To 2) As Long
Dim strRangeAddress As String, coll As Collection, rngPrintRange As Range
    If ws Is Nothing Then Exit Function
    Set coll = New Collection
    With ws
        ' determine if a print range is set
        On Error Resume Next
        Set rngPrintRange = .Range(.PageSetup.PrintArea)
        On Error GoTo 0
        
        ' determine the last used cell
        With .Range("A1").SpecialCells(xlCellTypeLastCell)
            r(2) = .Row
            c(2) = .Column
        End With
        
        ' count page breaks (manual+automatic)
        h(2) = .HPageBreaks.Count
        v(2) = .VPageBreaks.Count
        
        For v(1) = 0 To v(2)
            For h(1) = 0 To h(2)
                strRangeAddress = vbNullString
                ' upper left cell
                r(1) = 1
                c(1) = 1
                If h(1) > 0 Then
                    r(1) = .HPageBreaks(h(1)).Location.Row
                End If
                If v(1) > 0 Then
                    c(1) = .VPageBreaks(v(1)).Location.Column
                End If
                strRangeAddress = .Cells(r(1), c(1)).Address & ":"
                
                ' lower right cell
                r(1) = r(2)
                c(1) = c(2)
                If h(1) < h(2) Then
                    r(1) = .HPageBreaks(h(1) + 1).Location.Row - 1
                End If
                If v(1) < v(2) Then
                    c(1) = .VPageBreaks(v(1) + 1).Location.Column - 1
                End If
                strRangeAddress = strRangeAddress & .Cells(r(1), c(1)).Address
                
                ' add the range to the collection that the function will return
                If Not rngPrintRange Is Nothing Then ' a print range is set
                    ' return only the range intersecting the print range
                    strRangeAddress = Intersect(.Range(strRangeAddress), rngPrintRange).Address
                End If
                On Error Resume Next
                coll.Add strRangeAddress, strRangeAddress
                On Error GoTo 0
            Next h(1)
        Next v(1)
    End With
    If coll.Count > 0 Then
        Set GetPageRangeAddresses = coll
    End If
    Set rngPrintRange = Nothing
    Set coll = Nothing
End Function

Sub TestGetPageRangeAddresses()
Dim coll As Collection, i As Integer, strResult As String
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    Set coll = GetPageRangeAddresses(ActiveSheet)
    If coll Is Nothing Then Exit Sub
    strResult = vbNullString
    For i = 1 To coll.Count ' contains the cell range address for each page
        strResult = strResult & "Page " & i & ": " & coll(i) & vbLf
    Next i
    MsgBox strResult, vbInformation, "Page Ranges in " & ActiveSheet.Name
    Set coll = Nothing
End Sub

Document last updated 2004-10-08 09:26:06 Printerfriendly version

User comments:

Rob carey from Anywhere, USA wrote (2004-10-09 07:03:54 CET):

What a guy!
Ole P. you saved me from a watery grave. Not in a hundred years could I have devised this code.
I thank you ..my wife thanks you.

ps I'm shootin' for the dripless ice cream.