Sub CreateSheetsExportPDFandJPG()
Dim ws As Worksheet, dataWs As Worksheet
Dim cell As Range
Dim uniqueValues As New Collection
Dim folderPath As String, filterValue As Variant
Dim lastRow As Long, lastCol As Long
Dim sheetName As String
Dim i As Long
' --- CONFIGURATIE ---
Set dataWs = ThisWorkbook.Sheets("Hoofdblad")
folderPath = ThisWorkbook.Path & "\Exports_" & Format(Now, "yyyymmdd_HHMM") & "\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Filter resetten op bronblad
If dataWs.FilterMode Then dataWs.ShowAllData
dataWs.AutoFilterMode = False
' Laatste rij bepalen
lastRow = dataWs.Cells(dataWs.Rows.Count, "B").End(xlUp).Row
If lastRow < 2 Then
MsgBox "Geen data gevonden in kolom B vanaf rij 2.", vbExclamation
GoTo Afsluiten
End If
' --- MAPPEN MAAK ---
If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath
If Dir(folderPath & "PDF\", vbDirectory) = "" Then MkDir folderPath & "PDF\"
If Dir(folderPath & "JPG\", vbDirectory) = "" Then MkDir folderPath & "JPG\"
' --- UNIEKE WAARDEN VERZAMELEN (STAP 1) ---
' We lopen door kolom B en vullen de collectie
On Error Resume Next
For i = 2 To lastRow
Dim val As String
val = Trim(CStr(dataWs.Cells(i, 2).Value)) ' Trim haalt onnodige spaties weg
If val <> "" Then
uniqueValues.Add val, val
End If
Next i
On Error GoTo 0
' --- LOOP DOOR DE UNIEKE WAARDEN (STAP 2) ---
For Each filterValue In uniqueValues
' Naam opschonen
sheetName = Left(CStr(filterValue), 31)
sheetName = Replace(sheetName, "/", "-")
sheetName = Replace(sheetName, "\", "-")
sheetName = Replace(sheetName, ":", "")
' Verwijder bestaand blad met dezelfde naam (om duplicaten te voorkomen)
On Error Resume Next
ThisWorkbook.Sheets(sheetName).Delete
On Error GoTo 0
' 1. Nieuw blad maken
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = sheetName
' 2. Filter en kopieer op Hoofdblad
lastCol = 12 ' Kolom A t/m L
' Belangrijk: Eerst filter uitzetten voor we opnieuw filteren
dataWs.AutoFilterMode = False
With dataWs.Range(dataWs.Cells(1, 1), dataWs.Cells(lastRow, lastCol))
.AutoFilter Field:=2, Criteria1:=filterValue
.SpecialCells(xlCellTypeVisible).Copy Destination:=ws.Range("A1")
End With
' 3. Opmaak van het nieuwe blad
With ws.PageSetup
.PrintGridlines = True
.Orientation = xlPortrait
.PaperSize = xlPaperA4
.Zoom = 90
' Marges op 0 zoals gewenst
.LeftMargin = 0
.RightMargin = 0
.TopMargin = Application.InchesToPoints(0.16)
.BottomMargin = Application.InchesToPoints(0.16)
End With
' Kolombreedtes instellen
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. Export PDF
ws.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=folderPath & "PDF\" & sheetName & ".pdf"
' 5. Export JPG
ExportRangeToJPG ws.UsedRange, folderPath & "JPG\" & sheetName & ".jpg"
Next filterValue
Afsluiten:
dataWs.AutoFilterMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Klaar! Er zijn " & uniqueValues.Count & " tabbladen verwerkt.", vbInformation
End Sub
' --- DE HULPFUNCTIE VOOR JPG (MOET ONDERAAN STAAN) ---
Sub ExportRangeToJPG(rng As Range, filePath As String)
Dim chtObj As ChartObject
If rng Is Nothing Then Exit Sub
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set chtObj = rng.Parent.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top, _
Width:=rng.Width, Height:=rng.Height)
With chtObj
.Select
.Chart.Paste
.Chart.Export Filename:=filePath, FilterName:="JPG"
.Delete
End With
End Sub
