• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

VBA gevraagd voor het maken van filters en pdf's

S

Senso

Inventaris
Lid geworden
13 jun 2016
Berichten
11.847
Besturingssysteem
W11 Pro 25H2
Office versie
Office 2007 H&S en Office 2021 Prof Plus
Kolom A is jaren, kolom B de codes
1. Maak filters van de jaren die in kolom A staat en maak sheets met de naam 2020, 2021 etc.

2. Maak filters van de codes die in kolom B staan en maak sheets met de naam van de code A-001-L, B001 etc

3. Zijn alle sheets gemaakt, maak dan van alle sheets een aparte pdf. Ik zet het document in E:\Filters
Hoop dat het duidelijk is.
Kan best zijn dat ik dit al eens gevraagd heb, maar daar weet ik niets meer van. Geheugenverlies. En dan moet ik toch weer opnieuw beginnen.
 

Bijlagen

Laat maar even zitten. AI heeft een robuuste code geschreven en die ga ik eerst uitgebreid testen en heb ik vragen of problemen kom ik er op terug.
 
De code werkt goed, echter ik zou een aparte module willen hebben om de aangemaakte sheets te verwijderen. De originele sheet (bron) heeft de naam Filters. Die moet dus altijd blijven bestaan. Kan iemand daar de VBA voor schrijven?

Code: 
    ' Zet filters uit en herstel scherm
    wsSource.AutoFilterMode = False
    Application.ScreenUpdating = True

Code: 
 ' Optioneel: Verwijder het aangemaakte blad na export om je bestand schoon te houden
        ' Application.DisplayAlerts = False
        ' ws.Delete
        ' Application.DisplayAlerts = True
    Next filterValue
Dit laatste moet dus niet. Moet alleen als ik dat wil en niet automatisch.

edit:
Is gelukt, nu nog in het grote document verwerken.
 
Laatst bewerkt:
Ik krijg nu alle codes als sheets. Die sorteer ik met VBA. Ik kan nu alle sheets behalve de bronsheet wissen. Echter de marges worden niet overgenomen in de nieuwe sheets.

was links 0 en rechts 0
wordt links 1,8 en rechts 1,8

boven 0,4 en onder 0,4
wordt 1,9 en onder 1,9

De zoom wijzigt van 90 naar 100
De kolombreedtes worden niet aangepast naar de oude situatie.
Dat wordt dus een hele toer om dat allemaal goed te krijgen.
Dan moet je een VBA schrijven die dat allemaal aanpast.

Het moge dan ook duidelijk zijn dat de pdf's niet kloppen.
 
Ik krijg nu alle codes als sheets. Die sorteer ik met VBA. Ik kan nu alle sheets behalve de bronsheet wissen.
Klik om te vergroten...

Zoals je kunt lezen/begrijpen heb ik dat gedaan en de VBA zag er perfect uit en werkt in de proefopstelling uitstekend. Met wat uitbreidingen ging het ook goed maar de uitwerkingen bij het grote document zijn niet goed.

Het is logisch als de opmaak niet wordt overgenomen in de filters/nieuwe sheets dat er ook niets meer klopt van de pdf's.
Dus ik moet een macro opnemen die de de filters kan aanpassen. Maar dat kost mij altijd veel tijd.
 
Onderstaande de code die aangepast moet worden. Je krijgt dus allemaal foute pdf's. Punt is de marges, zoom, koptekst, kolombreedte e.d. kloppen niet. Ik bouw dan deze code in tussen 2 en 3
Let op. Dit is vermoedelijk onjuist:
Sheets(Array("Blad1", "Blad2", "Blad3")).Select
Sheets("Blad1").Activate
Dit moet van toepassing zijn op alle nieuwe aangemaakte filters/sheets of alle aanwezige sheets! Wat is dan de juiste regel?

Wie wil de code nakijken of deze juist zal werken.
edit:
Ik heb het geprobeerd en krijg Compileerfout
Er wordt End Sub verwacht. Foutonderbreking en MS zegt Excel werkt niet meer. Rapport naar Amerika e.d.

PHP: 
Attribute VB_Name = "Module1"
Sub CreateSheetsAndExportPDFs()
    Dim ws As Worksheet, dataWs As Worksheet
    Dim filterRange As Range, cell As Range
    Dim uniqueValues As New Collection
    Dim folderPath As String, filterValue As Variant
  
    ' --- CONFIGURATIE ---
    Set dataWs = ThisWorkbook.Sheets("Hoofdblad") ' Naam van je brondata blad
    ' De kolom waarop je filtert (bijv. kolom A vanaf rij 2)
    Set filterRange = dataWs.Range("B2:B" & dataWs.Cells(dataWs.Rows.Count, "A").End(xlUp).Row)
    folderPath = ThisWorkbook.Path & "\PDF_Exports\"
    ' --------------------

    ' Maak exportmap aan als deze nog niet bestaat
    If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath

    ' Verzamel unieke waarden uit de filterkolom
    On Error Resume Next
    For Each cell In filterRange
        If cell.Value <> "" Then uniqueValues.Add cell.Value, CStr(cell.Value)
    Next cell
    On Error GoTo 0

    ' Loop door elke unieke waarde
    For Each filterValue In uniqueValues
        ' 1. Maak een nieuw blad aan
        Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
        ws.Name = Left(CStr(filterValue), 31) ' Bladnaam max 31 tekens

        ' 2. Filter data en kopieer zichtbare cellen naar nieuw blad
        dataWs.UsedRange.AutoFilter Field:=2, Criteria1:=filterValue
        dataWs.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=ws.Range("A1")
        dataWs.AutoFilterMode = False

Sub SheetsAanpassen()
'
' SheetsAanpassen Macro
'

'
    Sheets(Array("Blad1", "Blad2", "Blad3")).Select
    Sheets("Blad1").Activate
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0.15748031496063)
        .BottomMargin = Application.InchesToPoints(0.15748031496063)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .PrintHeadings = False
        .PrintGridlines = True
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 90
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0.15748031496063)
        .BottomMargin = Application.InchesToPoints(0.15748031496063)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .PrintHeadings = False
        .PrintGridlines = True
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 90
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    ActiveWindow.Zoom = 100
    Columns("A:A").Select
    Selection.ColumnWidth = 5.71
    Columns("B:B").Select
    Selection.ColumnWidth = 6.57
    Columns("C:C").Select
    Selection.ColumnWidth = 14
    Columns("D:D").Select
    Selection.ColumnWidth = 0.5
    Columns("E:E").Select
    Selection.ColumnWidth = 10.29
    Columns("F:F").Select
    Selection.ColumnWidth = 11
    Columns("G:G").Select
    Selection.ColumnWidth = 10
    Columns("H:H").Select
    Selection.ColumnWidth = 10
    Columns("I:I").Select
    Selection.ColumnWidth = 10.14
    Columns("J:J").Select
    Selection.ColumnWidth = 9.14
    Columns("K:K").Select
    Selection.ColumnWidth = 8
    Columns("L:L").Select
    Selection.ColumnWidth = 9
    Sheets("Blad1").Select
End Sub

        ' 3. Exporteer het nieuwe blad naar PDF
        ws.ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=folderPath & ws.Name & ".pdf", _
            Quality:=xlQualityStandard

        ' Optioneel: Verwijder het aangemaakte blad na export om je bestand schoon te houden
        ' Application.DisplayAlerts = False
        ' ws.Delete
        ' Application.DisplayAlerts = True
    Next filterValue

    MsgBox "Klaar! De PDF's zijn opgeslagen in: " & folderPath
End Sub
 
Laatst bewerkt:
Ik heb geen verstand van VBA maar dit zegt Chatgpt
Vervelend dat Excel vastloopt, maar de oorzaak is gelukkig heel duidelijk. Je krijgt de foutmelding "End Sub verwacht" omdat je midden in een bestaande macro (CreateSheetsAndExportPDFs) een nieuwe macro-kop (Sub SheetsAanpassen()) hebt geplakt. In VBA mag je nooit een Sub binnen een andere Sub zetten.

Daarnaast klopt je vermoeden: Sheets(Array("Blad1", ...)).Select werkt niet, omdat die bladen in jouw loop telkens een andere naam krijgen.
Ben benieuwd.

Code: 
Attribute VB_Name = "Module1"
Sub CreateSheetsAndExportPDFs()
    Dim ws As Worksheet, dataWs As Worksheet
    Dim filterRange As Range, cell As Range
    Dim uniqueValues As New Collection
    Dim folderPath As String, filterValue As Variant
 
    ' --- CONFIGURATIE ---
    Set dataWs = ThisWorkbook.Sheets("Hoofdblad") ' Naam van je brondata blad
    ' De kolom waarop je filtert (bijv. kolom B vanaf rij 2)
    Set filterRange = dataWs.Range("B2:B" & dataWs.Cells(dataWs.Rows.Count, "A").End(xlUp).Row)
    folderPath = ThisWorkbook.Path & "\PDF_Exports\"
    ' --------------------

    ' Maak exportmap aan als deze nog niet bestaat
    If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath

    ' Verzamel unieke waarden uit de filterkolom
    On Error Resume Next
    For Each cell In filterRange
        If cell.Value <> "" Then uniqueValues.Add cell.Value, CStr(cell.Value)
    Next cell
    On Error GoTo 0

    ' Loop door elke unieke waarde
    For Each filterValue In uniqueValues
        ' 1. Maak een nieuw blad aan
        Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
        ws.Name = Left(CStr(filterValue), 31)

        ' 2. Filter data en kopieer naar nieuw blad
        dataWs.UsedRange.AutoFilter Field:=2, Criteria1:=filterValue
        dataWs.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=ws.Range("A1")
        dataWs.AutoFilterMode = False

        ' --- STAP 3: OPMAAK (Toegepast op het nieuwe blad 'ws') ---
        With ws.PageSetup
            .LeftMargin = Application.InchesToPoints(0)
            .RightMargin = Application.InchesToPoints(0)
            .TopMargin = Application.InchesToPoints(0.16)
            .BottomMargin = Application.InchesToPoints(0.16)
            .HeaderMargin = Application.InchesToPoints(0.31)
            .FooterMargin = Application.InchesToPoints(0.31)
            .PrintGridlines = True
            .Orientation = xlPortrait
            .PaperSize = xlPaperA4
            .Zoom = 90 ' Hier stel je de zoom in voor de PDF
        End With

        ' Kolombreedtes instellen op het nieuwe blad
        ws.Columns("A").ColumnWidth = 5.71
        ws.Columns("B").ColumnWidth = 6.57
        ws.Columns("C").ColumnWidth = 14
        ws.Columns("D").ColumnWidth = 0.5
        ws.Columns("E").ColumnWidth = 10.29
        ws.Columns("F").ColumnWidth = 11
        ws.Columns("G:I").ColumnWidth = 10
        ws.Columns("J").ColumnWidth = 9.14
        ws.Columns("K").ColumnWidth = 8
        ws.Columns("L").ColumnWidth = 9

        ' 4. Exporteer het nieuwe blad naar PDF
        ws.ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=folderPath & ws.Name & ".pdf", _
            Quality:=xlQualityStandard

        ' Optioneel: Verwijder het blad na export (haal de apostrof weg om te activeren)
        ' Application.DisplayAlerts = False
        ' ws.Delete
        ' Application.DisplayAlerts = True
    Next filterValue

    MsgBox "Klaar! De PDF's staan in: " & folderPath
End Sub
 
Attribute VB_Name = "Module1"
gewijzigd in:
'Attribute VB_Name = "Module1"

Eerste uitvoering Fout 104
Methode Autofilter van klasse Range is mislukt
dataWs UsedRange Field:=2 (is goed kolom B)..... is geel
Tweede uitvoering


ws.Name = Left(CStr(filterValue), 31).jpg
 
Je moet ingelogd zijn om te kunnen reageren. Log in | Registreer
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan