Styring af antal linier i udskriften.

Kunne et alternativ ikke være at indsætte sideskift, hvis et skema ikke kunne være på siden?

Hvor mange rækker er der plads til på en udskriftsside?

På første side er der 3 linier med overskrifter. Dernæst er der 37 linier. De 37 linier anvendes til at udskrive en slags records der består af et variabelt antal linier (typisk 3 til 4). Hver record adskilles af 2 blanke linier. Den næste side starter med en linie som overskrift og fortsætter med udskrift af record.

Har du mulighed for en sende en prøve på skema(er) til: pb@supertekst-it.dk

Filen er afsendt
mvh.
hubertus

Koden er placeret i arket med udskriften:

Const side1Ræk = 35                                'excl. overskrift
Const SideXRæk = 38                                '-"-
Dim antalRæk, overskriftsRække, sideRæk, sideNr, linieCount, skemaRækker
Sub udskriftStyring()
Dim ræk
    Worksheets(1).ResetAllPageBreaks                'fjerner alle sidesift
    sideNr = 0
    linieCount = 0
    sideRæk = side1Ræk
   
    antalRæk = ActiveCell.SpecialCells(xlLastCell).Row
    fjernBlankeRækker
   
    For ræk = 1 To antalRæk
        If InStr(Cells(ræk, 1), "Bil") > 0 Then
            If sideNr = 0 Then
                sideNr = sideNr + 1
            Else
                udførSideSkift ræk
            End If
            overskriftsRække = ræk                    'gem række for sidste overskrift
        Else
Rem Test om skema-Start
            If InStr(Cells(ræk, 1), "(") > 0 And InStr(Cells(ræk, 1), ")") > 0 Then
                skemaRækker = beregnSkemaRækker(ræk + 1)
Rem er der plads på siden
                If sideRæk - linieCount - skemaRækker <= 0 Then
Rem - nej
                    udførSideSkift ræk
                Else
Rem - ja
                    If sideRæk - linieCount - skemaRækker > 1 Then
                        indsætLinier ræk + skemaRækker, 2
                        ræk = ræk + skemaRækker + 1
                    Else
                        indsætLinier ræk + skemaRækker, 1
                        ræk = ræk + skemaRækker
                    End If
                End If
            End If
        End If
    Next ræk
   
    MsgBox ("Udskriftsstyring afsluttet")
End Sub
Private Function beregnSkemaRækker(ræk)            'hvor meget fylder skemaet
Dim antalR
    antalR = 1
    For r = ræk To antalRæk
        If Cells(r, 1) = "" Or InStr(Cells(r, 1), "(") > 0 And InStr(Cells(r, 1), ")") > 0 Or _
            InStr(Cells(r, 1), "Bil") > 0 Then
            beregnSkemaRækker = antalR
            Exit Function
        Else
            antalR = antalR + 1
        End If
    Next r
End Function
Private Sub udførSideSkift(ræk)
    Cells(ræk, 1).Activate
   
    If InStr(Cells(ræk, 1), "Bil") > 0 Then
        ActiveWorkbook.ActiveSheet.HPageBreaks.Add Before:=ActiveCell
    Else
        ActiveWorkbook.ActiveSheet.HPageBreaks.Add Before:=ActiveCell
Rem indsæt aktuelle overskrift
        Range("A" & CStr(overskriftsRække) & ":N" & CStr(overskriftsRække)).Select
        Selection.Copy
        Rows(CStr(ræk) & ":" & CStr(ræk)).Select
        Selection.Insert Shift:=xlDown
    End If
   
    linieCount = 0
    sideNr = sideNr + 1
    sideRæk = SideXRæk
End Sub
Private Sub indsætLinier(ræk, antal)
    For r = 1 To antal
        Rows(CStr(ræk) & ":" & CStr(ræk)).Select
        Selection.Insert Shift:=xlDown
        ræk = ræk + 1
    Next r
    linieCount = linieCount + skemaRækker + antal
End Sub
Private Sub fjernBlankeRækker()
    For ræk = antalRæk To 1 Step -1
        If Cells(ræk, 1) = "" Or IsEmpty(Cells(ræk, 1)) = True Then
            Rows(CStr(ræk) & ":" & CStr(ræk)).Select
            Selection.Delete Shift:=xlUp
        End If
    Next ræk
End Sub