Returning the page range addresses from a worksheet
2004-10-08 Worksheets 0 595
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