Skriv ut flere merkede områder på ett ark

Du er sikkert klar over at du kan skrive ut bare de merkede cellene i et regneark ved å velge Fil, Skriv ut…, Utvalg (Excel5/Excel95) eller Fil, Skriv ut…, Merket område (Excel97). Når du merker flere områder av arket og prøver å skrive ut på samme måte vil du derimot få hvert enkelt område utskrevet på hvert sitt ark. Ved hjelp av makroen nedenfor kan du få skrevet ut flere merkede områder samtidig på samme ark, forutsatt att de merkede områdene ikke er større enn det som går inn på en side.

Sub PrintSelectedCells()
' skriver ut de merkede cellene, kan knyttes til en verktøylinjeknapp eller meny
Dim aCount As Integer, cCount As Integer, rCount As Integer
Dim i As Integer, j As Long, aRange As String
Dim rHeight() As Single, cWidth() As Single, AWB As Workbook, NWB As Workbook
    If UCase(TypeName(ActiveSheet)) <> "WORKSHEET" Then Exit Sub 
    ' virker bare i regneark
    aCount = Selection.Areas.Count
    If aCount = 0 Then Exit Sub ' ingen celler er merket
    cCount = Selection.Areas(1).Cells.Count
    If aCount > 1 Then ' flere områder er merket
        Application.ScreenUpdating = False
        Application.StatusBar = "Skriver ut " & _
            aCount & " merkede områder..."
        Set AWB = ActiveWorkbook
        rCount = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
        cCount = ActiveSheet.Cells.SpecialCells(xlLastCell).Column
        ReDim rHeight(rCount)
        ReDim cWidth(cCount)
        For i = 1 To rCount ' finn radhøyden til hver enkelt rad
            rHeight(i) = Rows(i).RowHeight
        Next i
        For i = 1 To cCount ' finn kolonnebredden til hver enkelt kolonne
            cWidth(i) = Columns(i).ColumnWidth
        Next i
        Set NWB = Workbooks.Add ' oppretter en ny arbeidsbok
        For i = 1 To rCount ' angi radhøyden til hver enkelt rad
            Rows(i).RowHeight = rHeight(i)
        Next i
        For i = 1 To cCount ' angi kolonnebredden til hver enkelt kolonne
            Columns(i).ColumnWidth = cWidth(i)
        Next i
        For i = 1 To aCount
            AWB.Activate
            aRange = Selection.Areas(i).Address ' adressen til området
            Range(aRange).Copy ' kopier området
            NWB.Activate
            With Range(aRange) ' lim inn verdier og formater
                .PasteSpecial Paste:=xlValues, Operation:=xlNone, _
                    SkipBlanks:=False, Transpose:=False
                .PasteSpecial Paste:=xlFormats, Operation:=xlNone, _
                    SkipBlanks:=False, Transpose:=False
            End With
            Application.CutCopyMode = False
        Next i
        NWB.PrintOut
        NWB.Close False 
        ' lukker den midlertidige arbeidsboken uten å lagre den
        Application.StatusBar = False
        AWB.Activate
        Set AWB = Nothing
        Set NWB = Nothing
    Else
        If cCount < 10 Then ' mindre enn 10 celler er merket
            If MsgBox("Er du sikker på at du vil skrive ut " & _
                cCount & " merkede celler ?", _
                vbQuestion + vbYesNo, "Skriv ut merkede celler") = vbNo Then Exit Sub
        End If
        Selection.PrintOut
    End If
End Sub

Dokumentet er sist oppdatert 2000-02-04 12:35:45 Utskriftsvennlig versjon