Selecties afdrukken in excel

[jos0707]

hulp

Hey Spaarie,
bedankt voor je hulp maar het lukt me, zoals te verwachten, niet. Mijn kennis van VB is zeer beperkt.
In bijlage het testbestand. Als ik in datum 19/12 selecteer en dan de macro uitvoer werkt het niet.
Alvast bedankt.
Grts,
Jos

 

[spaarie]

Work aroundje gemaakt...
Zal je er niet te veel mee vermoeien om het uit te leggen en gewoon de code plaatsen

Sub PerKlant()
'In dit bestand zit nog een Blad2 met gekoppelde gegevens naar de gammalijst paté
    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").EntireColumn.Hidden = True
        
        .Columns(3).SpecialCells(2).Offset(1).SpecialCells(2).Copy .Range("AA10000")

        On Error Resume Next
        For Each c In .Columns(27).SpecialCells(2)
            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
            Sheets.Add , Sheets(Sheets.Count)
            With ActiveSheet
                .Cells(2, 1).PasteSpecial
                With .Cells(1, 2)
                    .Value = Left(ActiveSheet.Range("c3"), 25)
                    .Font.Bold = True
                    .Font.Size = 16
                End With

                .Columns.AutoFit
                .Name = ActiveSheet.Range("c3")
                .Columns(3).Delete
                ActiveWindow.DisplayZeros = False

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

                Application.Goto Cells(2, 1)
            End With
        Next w
        Application.Goto Sheets(1).Cells(1)
        .Cells.AutoFilter 3
        .Columns(27).ClearContents
    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
    Sheets(1).Columns("R:T").EntireColumn.Hidden = False

'In dit bestand zit nog een Blad2 met gekoppelde gegevens naar de gammalijst paté
End Sub

 

[jos0707]

Spaarie, als ik dat uitvoer op een langere lijst, dan krijg ik volgende foutmeldingen, die we eigenlijk al hadden onderkend in de programmatie maar blijkbaar niet meer werken.
zie bijlage

 

[jos0707]

Hey Spaarie,
ik heb de foutmeldingen kunnen aanpassen en het werkt goed, alleen krijg ik een laatste blad dat foutmeldingen geeft omdat hij daar geen naam kan aan geven. De reden is dat het programma niet stopt bij de laatste klant in komom C maar doorgaat tot de 10000 lijnen denk ik.
Grts,
Jos

 

[spaarie]

Jos,
Het spijt me maar ik kan het niet nabootsen...

Hoeveel regels heeft je originele bestand?

 

[jos0707]

Spaarie, Hartelijk dank ik denk dat het opgelost is. Ik ga nog wat testen. Als alles ok is zet ik het weer op opgelost.
Bedankt.
Grts,
Jos

 

[jos0707]

Spaarie,
als ik de macro laat lopen na een datum geselecteerd te hebben loopt dat prima. Als ik echter nu de macro laat lopen en wil de 3 klanten, dan maakt hij nog een 4 de blad aan waar hij op vast loopt. Er ontbreekt nog een stukje denk ik zodat hij stopt bij een leeg veld in C en niet doorgaat tot 10000 lijnen
Grts,
Jos

 

[spaarie]

Ik weet niet waar het precies in zit, omdat in je geleverde bestand en onderstaande code bij mij goed werkt...
Heb nog een kleine aanpassingen gedaan, maar weet niet of het hiermee verholpen is.

Sub PerKlant()
'In dit bestand zit nog een Blad2 met gekoppelde gegevens naar de gammalijst paté
    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(27).ClearContents
        .Columns("S:S").EntireColumn.Hidden = True
        .Columns(3).SpecialCells(2).Offset(1).SpecialCells(2).Copy .Range("AA10000")
        
        On Error Resume Next
        For Each c In .Columns(27).SpecialCells(2)
            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
            Sheets.Add , Sheets(Sheets.Count)
            With ActiveSheet
                .Cells(2, 1).PasteSpecial
                With .Cells(1, 2)
                    .Value = Left(ActiveSheet.Range("c3"), 25)
                    .Font.Bold = True
                    .Font.Size = 16
                End With

                .Columns.AutoFit
                .Name = ActiveSheet.Range("c3")
                .Columns(3).Delete
                ActiveWindow.DisplayZeros = False

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

                Application.Goto Cells(2, 1)
            End With
        Next w
        Application.Goto Sheets(1).Cells(1)
        .Cells.AutoFilter 3
        .Columns(27).ClearContents
    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
    Sheets(1).Columns("R:T").EntireColumn.Hidden = False
    Application.ScreenUpdating = True
    

'In dit bestand zit nog een Blad2 met gekoppelde gegevens naar de gammalijst paté
End Sub

 

[jos0707]

Dat ziet er zeer goed uit.
Waarom eigenlijk [.Columns(27).ClearContents] Vanwaar die kolom 27? Daar staat toch niets in.
Bedankt.
Groeten,
Jos

 

[spaarie]

Dat is voor de workaround waar ik het over had...

Eer de collectie 'uniekewaarden' wordt gemaakt, kopieer ik je selectie naar cel AA10000 (zie code). Vanaf hier laat ik de code unieke waardes opsommen, maar deze moet natuurlijk ook weer leeg gemaakt worden.
Vandaar de .Columns(27) = kolom AA leegmaken...

 

[jos0707]

Bedankt