Aanpassing code Pagine Einde

[mvanbe]

Goedemiddag,

Hopelijk kan iemand mij helpen met het aanpassen van onderstaande code. Deze werkt prima alleen het lukt mij niet om deze uit te breiden.

Deze code zoekt naar het trefwoord "Totaal" en als deze is gevonden wordt er een pagina einde ingevoegd. Graag zou ik willen dat na deze actie er een rij wordt ingevoegd en daarin de header die op rij 1 staat wordt geplakt. (in mijn originele bestand is deze header onderdeel van een tabel die meer of minder kolommen kan hebben)

Een 2de wens die ik heb is dat deze code geen pagina einde invoegd midden in een cluster omschrijvingen (bijvoorbeeld ergens in E25 t/m 39 of 42 E43 t/m E63

In het voorbeeldbestand heb ik geprobeerd het toe te lichten.

Sub Specificatie_pagebreak()

    Dim FoundCell As Range
    Dim FirstAddress As String
    Dim PrevAddress As String
    Dim SearchTerm As String
    
    verwijder_bestaande_pagebreak
    
    SearchTerm = "Totaal"
    
    With Columns("E")
        Set FoundCell = .Find(SearchTerm, LookIn:=xlValues, lookat:=xlPart, MatchCase:=True)
        If Not FoundCell Is Nothing Then
            FoundCell.Name = "FirstAddress"
            Do
                PrevAddress = FoundCell.Address
                ActiveSheet.HPageBreaks.Add Before:=Range(PrevAddress).Offset(1, 0)
              
                Set FoundCell = .FindNext(FoundCell)
            Loop While FoundCell.Address <> Range("FirstAddress").Address
        Else
            MsgBox "Pagina instelling niet gelukt; Controleer trefwoord Totaal", vbExclamation
        End If
    End With
End Sub

Sub verwijder_bestaande_pagebreak()
    Dim lX As Long
    For lX = ActiveSheet.HPageBreaks.Count To 1 Step -1
        ActiveSheet.HPageBreaks(lX).Delete
    Next
End Sub

 

[AD1957]

Voorbeeldbestand is wel heel erg leeg.:d

 

[mvanbe]

Voorbeeldbestand is wel heel erg leeg.:d

Excuses. Bij deze aangepast

 

[AD1957]

1e vraag: probeer het eens zo.

ActiveSheet.HPageBreaks.Add Before:=Range(PrevAddress).Offset(1, 0)
FoundCell.Offset(2, 0).EntireRow.Insert
FoundCell.Offset(1) = Range("E1")

 

[mvanbe]

Hoi Albert,

Bedankt voor je reactie. Dit is helaas nog niet de oplossing. Met deze toevoeging wordt alleen de inhoud van E1 na de pagina einde toegevoegd.

Het is de bedoeling dat de complete inhoud inclusief opmaak van rij 1 wordt gekopieerd na de gecreeerde pagina einde. Eigen experimenten mislukken nog steeds.

 

[AD1957]

zo?

ActiveSheet.HPageBreaks.Add Before:=Range(PrevAddress).Offset(1, 0)
                FoundCell.Offset(2, 0).EntireRow.Insert
                Range("A1:F1").Copy
                FoundCell.Offset(1, -4).Select
                ActiveSheet.Paste
                Application.CutCopyMode = False

 

[HSV]

Iets simpels AD1957,

Range("A1:F1").Copy foundcell.Offset(1, -4)

Zo kan je Select, Paste en CutCopymode vervallen.
Over de vraag heb ik verder geen idee.

 

[AD1957]

Harry,

Kort maar krachtig, had geen idee dat het zo ook kon.
Weer wat geleerd.:thumb:

 

[mvanbe]

Dit is de oplossing. Perfect!

Ik ga zelf een poging wagen om er voor te zorgen dat er geen pagina einde midden in een groep regels wordt geplaatst.

Nogmaals dank!

 

[AD1957]

Ik denk dat je dit bedoeld.
Gebruik voor subtelling het woord subtotaal en niet Totaal en pas het rode gedeelte aan.

Set FoundCell = .Find(SearchTerm, LookIn:=[COLOR="#FF0000"]Left(xlValues, 6)[/COLOR], lookat:=xlPart, MatchCase:=True)

 

[mvanbe]

Nee helaas.

Ik heb een afbeelding toegevoegd zoals bijna op elke pagina voorkomt in mijn huidige rapport.

In kolom E wordt een pagina einde ingevoegd midden in een 'cluster' van items. Dat staat in het definitief rapport niet zo fraai.

 

[AD1957]

probeer dit eens, boven End Sub

ActiveWindow.View = xlNormalView

 

[mvanbe]

Bedankt voor je hulp Albert. Je voorgestelde code geeft een weergave zonder pagina einde. De daadwerkelijke pagina einde blijft gewoon intact en dit is te zien in mijn definitieve rapportage.

Wat ik dus zou willen is dat de pagina einde niet midden in een groep regels wordt geplaatst maar bij de eerste bovenstaande lege regel. In de de afbeelding zou hij dus op regel 113 geplaatst moeten worden.

Hopelijk ben ik duidelijk genoeg

 

[AD1957]

Zou hier niet zo snel een oplossing voor weten. Misschien iemand anders ?
Misschien iets met de lege regel ? , maar je loopt dan waarschijnlijk de kans op half gevulde/of nog minder gevulde pagina's.
Mijn kennis van VBA is vooralsnog onvoldoende, dus maar even afwachten.

 

[HSV]

De header kan je gewoon meenemen in je printactie.

 

[pixcel]

Je 1e wens: die rij invoegen is niet nodig, daarvoor kun je PageSetup.PrintTitleRows = "$1:$1" gebruiken zoals hsv suggereert.
Je 2e wens: wat je kunt doen is het volgende: na de loop waarin de manual pagebreaks gemaakt zijn moet je kolom E in een nieuw loop cel voor cel doorlopen op zoek naar automatische pagebreaks (stippellijntjes). Als je er een hebt gevonden en de cel daarvan is niet leeg zit je midden in een lijst. Vanaf die rij loop je weer terug tot je een lege cel hebt gevonden (of een manual pagebreak, dan heb je pech). Op die lege cel plaats je een manual break. Hierdoor zal de automatische break verderop verdwijnen, vanaf die regel ga je weer verder zoeken.

Het verwijderen van alle pagebreaks kan eenvoudiger met de opdracht ResetAllPageBreaks van het worksheet.