Returner celleadressene til sidene i et regneark

Den egendefinerte funksjonen nedenfor kan benyttes til å returnere en samling med sideadresser i et regneark. Dette kan være nyttig dersom man trenger å kunne refereres til cellene i en spesiell side (f. eks. når man skal formatere eller kopiere).

Function GetPageRangeAddresses(ws As Worksheet) As Collection
' returnerer en samling med celleadresser for hver enkelt side i rengearket
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
        ' sjekk om et utskriftsområde er satt
        On Error Resume Next
        Set rngPrintRange = .Range(.PageSetup.PrintArea)
        On Error GoTo 0
        
        ' bestem den siste benyttede cellen
        With .Range("A1").SpecialCells(xlCellTypeLastCell)
            r(2) = .Row
            c(2) = .Column
        End With
        
        ' tell sideskiftene (manuelle+automatiske)
        h(2) = .HPageBreaks.Count
        v(2) = .VPageBreaks.Count
        
        For v(1) = 0 To v(2)
            For h(1) = 0 To h(2)
                strRangeAddress = vbNullString
                ' cellen øverst til venstre
                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 & ":"
                
                ' cellen nederst til høyre
                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
                
                ' legg celleadressene til samlingen som funksjonen skal returnere
                If Not rngPrintRange Is Nothing Then ' et utskriftsområde er satt
                    ' returner kun området som overlapper utskriftsområdet
                    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 ' inneholder adressene til celleområdene for hver eneste side
        strResult = strResult & "Side " & i & ": " & coll(i) & vbLf
    Next i
    MsgBox strResult, vbInformation, "Celleadresser til sidene i " & ActiveSheet.Name
    Set coll = Nothing
End Sub

Dokumentet er sist oppdatert 2004-10-08 09:26:06 Utskriftsvennlig versjon