Ophogen cel bij printen van bepaald aantal kopieen

[jodelo]

Hallo forumleden:

Het volgende probleem dient zich aan.
Op mijn werk heb ik een formulier gemaakt voor een ingangscontrolle voor binnenkomende goederen. (via VBA)
Dit formulier heeft een nummer dat bij het printen van nieuwe formulieren voor de medewerkers wordt opgehoogd met 1
Als ik dus b.v. vanaf nummer 1400, aangeef dat ik 300 formulieren wil printen dan krijg ik dus 300 formulieren genummerd van 1400 t/m 1699
Dit is precies wat ik wil, echter maakt de macro hier voor ieder nummer een nieuwe printopdracht aan. Dit duurt bij 300 stuks dus behoorlijk lang.

Is er een manier dat als ik aangeef dat ik 300 stuks wil, de printer deze achter elkaar print en niet stuk voor stuk.
Bijgevoegd een voorbeeld van het formulier. Drukt men op de knop PRINTEN dan kun je het aantal af te drukken formulieren ingeven en deze uitprinten.Bekijk bijlage Ingangscontroleformulier.xlsm

Alvast bedankt voor eventuele suggesties of oplossingen.

 

[Cobbe]

Doe eens de test met deze:

Sub test()
   ActiveWindow.SelectedSheets.PrintOut Copies:=InputBox("aantal afdrukken"), Collate:=True
End Sub

Private Sub Workbook_BeforePrint(Cancel As Boolean)
 Range("M1") = Range("M1") + 1
End Sub

 

[jodelo]

Hallo Cobbe,

Bedankt voor je bijdrage.
Ik heb hem getest met 10 pagina's die werden achter elkaar geprint, prima dus, maar op iedere pagina komt het zelfde nummer, hij hoogt dus niet op met 1.
Misschien heb je daar dan ook een oplossing voor.

Jodelo

 

[Cobbe]

Ik vrees ervoor, om een nummering mee te laten lopen zal je je printopdracht in een lus moeten steken
en dus daar in elke doorloop het nummer aanpassen.

 

[jodelo]

Hallo Kobbe:

In mijn originele vba code deed hij wel ophogen maar maakte hij voor iedere print een nieuwe printopdracht waardoor de printer steeds opnieuw moet opstarten en 1 print maken.
Er is dus niets te vinden om dit in deze code aan te passen neem ik aan ??

 

[Cobbe]

Test deze dan nog eens:

Sub PrintCopies_Formulier()
    Dim AantalCopies As Long
    Dim CopieNummer As Long
    AantalCopies = Application.InputBox("Hoeveel copies wil u printen", Type:=1)

    With ActiveSheet
        If Not IsNumeric(.Range("M1").Value) Then .Range("M1").Value = 0

        For CopieNummer = 1 To AantalCopies
            .Range("M1").Value = .Range("M1").Value + 1

            'Print the sheet
            .PrintOut

        Next CopieNummer
    End With
End Sub

 

[jodelo]

Hallo Cobbe:

Ik ben momenteel niet meer op m'n werk, maar ik kijk er maandag direct naar zodra ik op het werk ben.
Ik laat jullie weten of het werkt.
Alvast bedankt en een goed weekend.

 

[jodelo]

Hallo Cobbe:

Vanmorgen direct geprobeerd om 10 prints te maken. Hij doet dit wel en hoogt ze ook op met 1, maar het printen gaat weer stuk voor stuk en duurt dus behoorlijk lang.
Je kunt je voorstellen dat het printen van 500 formulieren behoorlijk wat tijd in beslag neemt plus dat dan de printer niet voor andere dingen gebruikt kan worden.
Ik denk persoonlijk dat het een moeilijke zaak wordt.
Misschien heb jij nog ideeen.

 

[Cobbe]

Test deze dan eens ('LET OP') wel op een copij uittesten.
Deze code copiëert een aantal bladen en verwijdert die ook aan het einde.
Enkel Blad1 blijft staan. Dus let op indien er nog iets anders in je werkboek staat.

Sub test()
Dim invoer As Integer
Dim i As Integer
Dim MyArray As String
invoer = InputBox("aantal afdrukken")
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
 With ActiveSheet
  For i = 1 To invoer
    .[M1] = .[M1] + 1
    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets("Blad1").Copy Sheets(Sheets.Count)
  Next
 End With
For bladen = 1 To Sheets.Count
 If Not Sheets(bladen).Name = "Blad1" Then
   MyArray = MyArray & Sheets(bladen).Name & ","
 End If
Next
Sheets(MyArray).PrintOut
  For y = Sheets.Count To 1 Step -1
   If Not Sheets(y).Name = "Blad1" Then
    Sheets(y).Delete
   End If
  Next
     .ScreenUpdating = True
     .DisplayAlerts = True
End With
End Sub

 

[Warme bakkertje]

Als ik deze thread lees begrijp ik eruit dat jij rechtstreeks in een printopdracht wil ingrijpen. Je stelt bv. 300 kopiëen in dus je maakt 1 printopdracht van 1 werkblad met 300 velletjes als resultaat.
Beschouw de printopdracht als een doos. Je vult de doos met af te drukken object(en) en sluit deze af >> 1 printopdracht. Eens deze doos echter gesloten is kan je er ook niet meer in ingrijpen.
Daarom zie ik de werkwijze van Cobbe als een rechtmatige workaround (misschien wel de enige). Maak een aantal kopies van het te printen werkblad, groepeer deze in 1 printopdracht en verwijder de kopies na het printen.

 

[jodelo]

Hallo Cobbe:

Zojuist getest en de macro begint met het maken van een aantal werkbladen.
Vanaf daar gebeurd er niks meer maar krijg ik de melding (Het subscript valt buiten het bereik)
Hij print dus helemaal niks.

 

[Cobbe]

Deze doet dat wel maar ik weet niet of het effectief sneller is.
Heb geen goesting om dit te testen via mijn printer en dus doe ik het via PrintPreview en dat loopt als een t..t !

Sub Cobbe()
Dim invoer As Integer
Dim i As Integer
Dim MyArray As String
invoer = InputBox("aantal afdrukken")
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
 With ActiveSheet
  For i = 1 To invoer
    .[M1] = .[M1] + 1
    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets("Blad1").Copy Sheets(Sheets.Count)
  Next
 End With
For bladen = 1 To Sheets.Count
 If Not Sheets(bladen).Name = "Blad1" Then
   Sheets(bladen).PrintPreview
   'MyArray = MyArray & Sheets(bladen).Name & ","
 End If
Next
   'Sheets(MyArray).PrintOut
  For y = Sheets.Count To 1 Step -1
   If Not Sheets(y).Name = "Blad1" Then
    Sheets(y).Delete
   End If
  Next
     .ScreenUpdating = True
     .DisplayAlerts = True
End With
End Sub

Ik blijf problemen hebben met het samenstellen en dan uitprinten van die Sheet.Array.

 

[jodelo]

Hallo Cobbe:

Deze print inderdaad en is ook iets sneller.
Ik hou het hier maar op want het lijkt er op dat hier geen passende oplossing voor is te vinden.
In ieder geval bedankt voor de hulp en we gaan het met deze proberen.
Nogmaals bedankt...

 

[Warme bakkertje]

Test deze dan eens.
Het oplopende nummer wordt in M1 geplaatst.

Sub Cobbe()
    Dim invoer As Integer, i As Integer, MyArray() As String
    invoer = InputBox("aantal afdrukken")
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        For i = 1 To invoer
            Sheets("Blad1").Copy Sheets(Sheets.Count)
            ActiveSheet.[A1] = i
        Next
        ArrayIndex = 0
        For i = 1 To Sheets.Count
            If Not Sheets(i).Name = "Blad1" Then
                ReDim Preserve MyArray(ArrayIndex)
                MyArray(ArrayIndex) = Sheets(i).Name
                ArrayIndex = ArrayIndex + 1
            End If
        Next i
        Sheets(MyArray).Select
        With ActiveWindow.SelectedSheets
            .PrintPreview 'PrintOut
            .Delete
        End With
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

 

[robdgr]

Identieke vraag is vandaag hier gestart

 

[jodelo]

Oke Cobbe, morgenvroeg op het werk test ik hem meteen.
Ik kan deze thuis niet uit proberen wegens het printen, dus je hoort morgen van mij.

 

[jodelo]

Hallo Cobbe:

Ook dit is het helaas niet. Hij laat printvoorbeelden zien maar print helemaal niets. Hij hoogt wel bij de voorbeelden het nummer met 1 op.
Ik wil je bedanken voor het proberen maar dit lijkt mij een oneindig verhaal te worden. Ik ga ze op een aparte printer uitprinten zodat collega's er geen last van hebben.
Toch bedankt voor jou tijd en moeite.

 

[Warme bakkertje]

Lees jij eigenlijk alle antwoorden die je krijgt ?
Mijn oplossing heb je nog eens niet geprobeerd.
Crossposten en aangedragen oplossingen negeren ?? Netjes.

 

[Cobbe]

Om die printvoorbeelden om te zetten in Printen moet je die PrintPreview wijzigen in PrintOut.
Wij hebben geen zin om steeds die prints te doen om code te testen en dus gebruiken we PrintPreview.

 

[jodelo]

Sorry Warme bakkertje ik had hem wel gezien maar niet gelezen omdat ik met het voorbeeld van Cobbe bezig was.
Ik ga het morgen direct proberen en laat het resultaat weten. Ik heb op mijn werk helaas niet altijd de tijd om de berichten na te kijken.
Nogmaals mijn excuses.