Selecties afdrukken in excel

jos0707 · 20 aug 2013

Bekijk bijlage Selectielijst vraag printen.xlsx

Graag had ik een oplossing (VB code ) voor het afdrukken van de lijst in bijlage en wel gegroepeerd per klant op 1 blad met de titellijn erboven.
Ik dacht ofwel aan een methode om dit vanaf “Blad1” af te drukken telkens er een andere “Klant” naam is ofwel te verplaatsen naar telkens een ander werkblad en dan af te drukken.
Bedoeling is dat een magazijnier één blad krijgt met daarop alle bestelde items van bijvoorbeeld klant Delft, hij de bestelling kan klaarzetten, en het blad bij de bestelling kan voegen.
Als het kan helpen is het wel mogelijk voor mij om tussen de verschillende lijnen per klant een blanco lijn in te voegen als we aan de volgende klant komen.
Het eindresultaat zou moeten zijn zoals op “Voorbeeld eindresultaat” wat ik dan kan afdrukken zodat alles op aparte bladen staat
Alvast bedankt voor de hulp.
Jos

spaarie · 21 aug 2013

Zoiets?
Druk op de knop 'druk op mij'.

Code:

Sub Spaarie()
    Dim uniek As New Collection, w As Variant
    
    Application.DisplayAlerts = False
    For i = 2 To Sheets.Count
        Sheets(i).Delete
    Next i
    Application.DisplayAlerts = True
    
    With Sheets(1)
        On Error Resume Next
        For Each c In .Range("D2:D" & .Range("D" & Rows.Count).End(xlUp).Row)
            uniek.Add c.Value, CStr(c.Value)
        Next c
        On Error GoTo 0
        For Each w In uniek
            .Cells.AutoFilter 4, w
            .Range("A1:K" & .Range("A" & Rows.Count).End(xlUp).Row).Copy
            Sheets.Add , Sheets(Sheets.Count)
            With ActiveSheet
                .Paste
                .Columns.AutoFit
                .Name = Range("D2")
                Application.Goto Cells(2, 1)
            End With
        Next w
        Application.Goto Sheets(1).Cells(1)
        .Cells.AutoFilter
    End With
    
    If MsgBox("Wilt u de lijsten printen?", vbInformation + vbYesNo, "Printen") = vbYes Then
        For i = 2 To Sheets.Count
            Sheets(i).PrintOut
        Next i
    End If
End Sub

jos0707 · 21 aug 2013

Opgelost!

Spaarie, je bent fantastisch! Je code doet juist wat ik wil. Hartelijk bedankt!!!

jos0707 · 21 aug 2013

Spaari, nog een, voor jou waarschijnlijk, kleine aanpassing indien mogelijk.
Is het mogelijk de naam van de "klant" op ieder blad boven de "omschrijving" te zetten en dan de kolom D (Klant) te laten wegvallen?
Alvast bedankt.

spaarie · 21 aug 2013

Heb hem iets aangepast, ook in het begin en einde met een ander 'For' routine.
Let er wel op wanneer je deze gaat gebruiken, dat de namen goed staan... (zoals Blad1)

Code:

Sub Spaarie()
    Application.ScreenUpdating = False
    Dim uniekewaarden As New Collection, w As Variant
    
    Application.DisplayAlerts = False
    For Each sh In Sheets
        If sh.Name <> "Blad1" Then sh.Delete
    Next sh
    Application.DisplayAlerts = True
    
    With Sheets(1)
        On Error Resume Next
        For Each c In .Range("D2:D" & .Range("D" & Rows.Count).End(xlUp).Row)
            uniekewaarden.Add c.Value, CStr(c.Value)
        Next c
        On Error GoTo 0
        For Each w In uniekewaarden
            .Cells.AutoFilter 4, w
            .Range("A1:K" & .Range("A" & Rows.Count).End(xlUp).Row).Copy
            Sheets.Add , Sheets(Sheets.Count)
            With ActiveSheet
                .Cells(2, 1).PasteSpecial
                .Cells(1, 3) = .Range("D3")
                .Columns.AutoFit
                .Name = Range("D3")
                .Columns(4).Delete
                Application.Goto Cells(2, 1)
            End With
        Next w
        Application.Goto Sheets(1).Cells(1)
        .Cells.AutoFilter
    End With
    
    If MsgBox("Wilt u de lijsten printen?", vbInformation + vbYesNo, "Printen") = vbYes Then
        For Each sh In Sheets
            If sh.Name <> "Blad1" Then sh.PrintOut
        Next sh
    End If
    Application.ScreenUpdating = True
End Sub

jos0707 · 21 aug 2013

Nog wat....

Spaarie, je bent een geweldige hulp voor mij.
Ik zou naast Blad1 nog een Blad2 blijvend willen invoegen waarin ik nog gegevens wil zetten zodat ik in blad1 vert.zoeken kan toepassen.
Maar als ik jou prachtige formule laat lopen verdwijnt dat blad telkens.
Kan je dat aub nog even aanpassen aub zodat blad2 blijft staan?
Hartelijk dank.
Grts,
Jos

spaarie · 21 aug 2013

Je moet zelf even kijken bij de onderste 'For' welke bladen je wilt afdrukken..

Code:

Sub Spaarie()
    Application.ScreenUpdating = False
    Dim uniekewaarden As New Collection, w As Variant
    
    Application.DisplayAlerts = False
    For i = 3 to Sheets.Count
        Sheets(i).Delete
    Next i
    Application.DisplayAlerts = True
    
    With Sheets(1)
        On Error Resume Next
        For Each c In .Range("D2:D" & .Range("D" & Rows.Count).End(xlUp).Row)
            uniekewaarden.Add c.Value, CStr(c.Value)
        Next c
        On Error GoTo 0
        For Each w In uniekewaarden
            .Cells.AutoFilter 4, w
            .Range("A1:K" & .Range("A" & Rows.Count).End(xlUp).Row).Copy
            Sheets.Add , Sheets(Sheets.Count)
            With ActiveSheet
                .Cells(2, 1).PasteSpecial
                .Cells(1, 3) = .Range("D3")
                .Columns.AutoFit
                .Name = Range("D3")
                .Columns(4).Delete
                Application.Goto Cells(2, 1)
            End With
        Next w
        Application.Goto Sheets(1).Cells(1)
        .Cells.AutoFilter
    End With
    
    If MsgBox("Wilt u de lijsten printen?", vbInformation + vbYesNo, "Printen") = vbYes Then
        For i = 3 to Sheets.Count
            Sheets(i).PrintOut
        Next i
    End If
    Application.ScreenUpdating = True
End Sub

jos0707 · 21 aug 2013

Klein foutje

Ik heb een blad toegevoegd (zie bijlage) en wanneer ik dan de code uitvoer krijg ik op de eerste Next sh een foutmelding.
Na blad 2 (wat een verborgen bald gaat worden) zou hij moeten beginnen met het zetten van de bestellingen voor de verschillende klanten en die dan al dan niet afdrukken.
Bedankt.Bekijk bijlage Foutje.pdf Bekijk bijlage Foutje.pdf Bekijk bijlage Foutje.pdf

spaarie · 21 aug 2013

Hahaha, sorry. Niet alles aangepast.
Nu wel hierboven

Module print vanaf pagina 3

jos0707 · 22 aug 2013

Werkt prima maar.... tot ik Vanbroeckhoven – Electrotechnishe Installaties tegenkwam. Toen kreeg ik de melding dat er maar 31 tekens zijn toegestaan. Wil je dat aub aanpassen dat bijvoorbeeld maar de eerste 20 tekens van de klantnaam gebruikt worden als bladnaam?
Hartelijk dank
Jos

spaarie · 22 aug 2013

Pas deze aan

Code:

.Name = Left(.Range("D3"), 20)

jos0707 · 22 aug 2013

Hallo Spaarie,
wat moet ik bijvoegen om de klantnaam bovenaan op ieder blad groter te krijgen op bijvoorbeeld 16 punten en vet gedrukt?
Alvast bedankt.
Groeten,
Jos

spaarie · 22 aug 2013

Vervang:

Code:

            With ActiveSheet
                .Cells(2, 1).PasteSpecial
                With .Cells(1, 3)
                    .Value = ActiveSheet.Range("D3")
                    .Font.Bold = True
                    .Font.Size = 16
                End With

jos0707 · 22 aug 2013

Bedankt voor de zeer snelle reactie en passende oplossing. In de code zit ook het afprinten in verwerkt. Kan dit ook Liggend en alle kolommen passend maken voor 1 pagina aub?
Wanneer ik nadien dan nog 1 pagina extra wil afdrukken staat die dan ook Liggend ingesteld en kolommen passend maken voor 1 pagina of moet ik dat dan manueel instellen?
Hartelijk dank.

spaarie · 22 aug 2013

Voor het gemak de gehele code nogmaal met aanpassing;
- Afdrukstand is liggend (ook voor de resterende pagina's die je afdrukt)
- Tabblad wordt automatisch op 1 pagina afgedrukt

Code:

Sub Spaarie()
    Application.ScreenUpdating = False
    Dim uniekewaarden As New Collection, w As Variant
    
    Application.DisplayAlerts = False
    For i = Sheets.Count To 3 Step -1
        Sheets(i).Delete
    Next i
    Application.DisplayAlerts = True
    
    With Sheets(1)
        On Error Resume Next
        For Each c In .Range("D2:D" & .Range("D" & Rows.Count).End(xlUp).Row)
            uniekewaarden.Add c.Value, CStr(c.Value)
        Next c
        On Error GoTo 0
        For Each w In uniekewaarden
            .Cells.AutoFilter 4, w
            .Range("A1:K" & .Range("A" & Rows.Count).End(xlUp).Row).Copy
            Sheets.Add , Sheets(Sheets.Count)
            With ActiveSheet
                .Cells(2, 1).PasteSpecial
                With .Cells(1, 3)
                    .Value = ActiveSheet.Range("D3")
                    .Font.Bold = True
                    .Font.Size = 16
                End With
                .Columns.AutoFit
                .Name = Left(.Range("D3"), 20)
                .Columns(4).Delete
                With .PageSetup
                    .Orientation = xlLandscape
                    .Zoom = False
                    .FitToPagesWide = 1
                    .FitToPagesTall = 1
                End With
                Application.Goto Cells(2, 1)
            End With
        Next w
        Application.Goto Sheets(1).Cells(1)
        .Cells.AutoFilter
    End With
    
    If MsgBox("Wilt u de lijsten printen?", vbInformation + vbYesNo, "Printen") = vbYes Then
        For i = 3 To Sheets.Count
            Sheets(i).PrintOut
        Next i
    End If
    Application.ScreenUpdating = True
End Sub

jos0707 · 22 aug 2013

Geweldig!
Hopelijk een laatste vraag want ik begin het nu wel wat vervelend te vinden je zoveel lastig te vallen.
Ik heb op blad1 een voettekst staan met de huidige datum en uur.
Deze zou ik graag ook hebben op de gegenereerde bladen per klant zodat de medewerker kan zien wanneer de laatste versie van de bestelling is afgedrukt.
Hartelijk dank.
Grts,
Jos

spaarie · 22 aug 2013

Je zou het ook eens kunnen Googlen of ga met de macrorecorder aan de slag...

Code:

                With .PageSetup
                    .Orientation = xlLandscape
                    .Zoom = False
                    .FitToPagesWide = 1
                    .FitToPagesTall = 1
                    .CenterFooter = Format(Now, "dd-mm-yyyy hh:mm")
                End With

jos0707 · 22 aug 2013

Nogmaals hartelijk dank voor alle hulp. Ik zet het item nu op gesloten.
Grts,
jos

jos0707 · 18 dec 2013

Dag Spaarie, ik heb nog een vaag over bovenstaande.
Application.ScreenUpdating = False
Dim uniekewaarden As New Collection, w As Variant

Application.DisplayAlerts = False
For i = 3 To Sheets.Count
Sheets(i).Delete
Next i
Application.DisplayAlerts = True

With Sheets(1)
Columns("S:S").Select
Selection.EntireColumn.Hidden = True

On Error Resume Next
For Each c In .Range("c2:c" & .Range("c" & Rows.Count).End(xlUp).Row)
uniekewaarden.Add c.Value, CStr(c.Value)
Next c
On Error GoTo 0
For Each w In uniekewaarden
.Cells.AutoFilter 3, w
.Range("A1:S" & .Range("A" & Rows.Count).End(xlUp).Row).Copy

Op deze lijn For Each c In .Range("c2:c" & .Range("c" & Rows.Count).End(xlUp).Row)
gaat het fout. Dit komt omdat ik door een datumfiltering lijnen 2 t.e.m. 10 niet nodig heb. Ik begin dus na lijn 1 op lijn 11, maar dat kan dus wisselen naagelang de filtering.
Is er een mogelijkheid om ipv ("c2:c" te zetten dat het moet beginnen te werken op de eerste rij die zichtbaar is na lijn1, de tittellijn, ook al is dat lijn 11?
Weerom bedankt voor uw hulp
Prettige feestdagen
Groeten,
Jos

spaarie · 18 dec 2013

Jos,
Wil je zo vriendelijk zijn volgende keer de code tussen de [ code] [ /code]-tags te plaatsen?

Probeer eens

Code:

for each c in .columns(3).specialcells(2).offset(1).specialcells(12)

of

Code:

for each c in .columns(3).specialcells(2).offset(1).specialcells(2)

Selecties afdrukken in excel

Gebruiker

Terugkerende gebruiker

Bijlagen

Gebruiker

Gebruiker

Terugkerende gebruiker

Gebruiker

Terugkerende gebruiker

Gebruiker

Terugkerende gebruiker

Gebruiker

Terugkerende gebruiker

Gebruiker

Terugkerende gebruiker

Gebruiker

Terugkerende gebruiker

Gebruiker

Terugkerende gebruiker

Gebruiker

Gebruiker

Terugkerende gebruiker

Wij waarderen jouw privacy