• 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.

Filter kolom A op iedere code etc.

S

Senso

Inventaris
Lid geworden
13 jun 2016
Berichten
11.686
Besturingssysteem
W11 Pro 25H2
Office versie
Office 2007 H&S en Office 2021 Prof Plus
Filter kolom A op iedere code en geef de sheet de naam van deze code en sla elke sheet op als pdf. Voorbeeldbestand volgt. De gewenste code moet ik regel voor regel in de VBA kunnen ingeven omdat er te veel codes zijn.
Het gaat hier om een proef/test.
De sheetnaam is Maand
Het bestand staat in E:\test\
De doelmap van de pdf's is E:\test\
De sheetnaam van het filter wordt de code (vb > 8400)
De pdf krijgt ook de naam van de code

Onderstaande code is van internet. Je zou ook een box kunnen maken met de vraag de code in te voeren. Dus van welke code/filter wilt u een pdf?

PHP: 
VBA Macro: Filter, Create Sheets, and Save as PDF
Replace "Sheet1" with your source sheet name and adjust Field:=1 to the column index of your "code" (e.g., Column A = 1, Column B = 2).
vba

Sub FilterAndSaveAsPDF()
    Dim ws As Worksheet, tempWs As Worksheet
    Dim lastRow As Long, i As Long
    Dim uniqueCodes As Collection
    Dim codeValue As Variant
    Dim savePath As String
 
    ' SETTINGS: Change these as needed
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Your source sheet
    savePath = ThisWorkbook.Path & "\"    ' Saves in the same folder as the Excel file
 
    Set uniqueCodes = New Collection
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' Assumes codes are in Column A
 
    ' 1. Get Unique Codes
    On Error Resume Next
    For i = 2 To lastRow ' Assumes header is in Row 1
        uniqueCodes.Add ws.Cells(i, 1).Value, CStr(ws.Cells(i, 1).Value)
    Next i
    On Error GoTo 0
 
    ' 2. Loop Through Each Unique Code
    Application.ScreenUpdating = False
    For Each codeValue In uniqueCodes
        ' Filter and Copy
        ws.UsedRange.AutoFilter Field:=1, Criteria1:=codeValue
   
        ' Create temporary sheet
        Set tempWs = Sheets.Add(After:=Sheets(Sheets.Count))
        tempWs.Name = "Temp_" & Left(codeValue, 25) ' Sheet names limited to 31 chars
   
        ' Copy visible data to temporary sheet
        ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=tempWs.Range("A1")
   
        ' 3. Save as PDF
        tempWs.ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=savePath & codeValue & ".pdf", _
            Quality:=xlQualityStandard
       
        ' Delete temporary sheet
        Application.DisplayAlerts = False
        tempWs.Delete
        Application.DisplayAlerts = True
    Next codeValue
 
    ' Clean up
    ws.AutoFilterMode = False
    Application.ScreenUpdating = True
    MsgBox "PDFs created successfully in: " & savePath
End Sub
 

Bijlagen

Laatst bewerkt:
Ik constateer nu dat de inhoud van de pdf totaal anders is dan de weergave op een sheet. Dus dan heeft het totaal geen zin.
 
Er gebeurt precies wat je wilt, maar heb je dit wel gezien?
Code: 
' Assumes header is in Row 1

Een voorbeeldje:
 

Bijlagen

Laatst bewerkt:
Andere methode die een lus minder nodig heeft.
Code: 
Sub hsv()
Dim sv, sd As Object, i As Long, Ws As Worksheet
Application.ScreenUpdating = 0
With Sheets("maand").Cells(1).CurrentRegion
sv = .Value
 Set sd = CreateObject("scripting.dictionary")
  For i = 2 To UBound(sv)
    If Not sd.exists(sv(i, 1)) Then
        sd.Item(sv(i, 1)) = sv(i, 1)
           Sheets.Add(, Sheets(Sheets.Count)).Name = "Temp_" & sv(i, 1)
           Set Ws = Sheets("Temp_" & sv(i, 1))  'of  set Ws  = Activesheet
      .AutoFilter 1, sv(i, 1)
      .Copy Ws.Cells(1)
      .AutoFilter
        Ws.ExportAsFixedFormat 0, ThisWorkbook.Path & "\" & sv(i, 1)
         Application.DisplayAlerts = 0
           Ws.Delete
         Application.DisplayAlerts = -1
    End If
  Next i
End With
End Sub
 
Ja, mooi. Echter als ik iedere pdf moet bewerken naar landscape dan heeft het maken van een pdf geen zin. Het gaat mij juist om een snelle preview van een filter/code per sheet.

Dus pdf vergeten en de opzet is dan, maak van iedere (gewenste) filter/code een sheet. Dan kan ik iedere sheet/filter snel bekijken.

Is dat deze?
Wie wil onderstaande werkend maken. Dus dat voor elk filter een sheet wordt gemaakt in het actieve document.

PHP: 
Sub filter()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last As Long
Dim sht As String

'specify sheet name in which the data is stored
sht = "Maand"

'change filter column in the following code
last = Sheets(sht).Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Sheets(sht).Range("A:A" & last)

Sheets(sht).Range("A:A" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True

For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))

With rng
.AutoFilter
.AutoFilter Field:=6, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy

Sheets.Add(after:=Sheets(Sheets.Count)).Name = x.Value
ActiveSheet.Paste
End With
Next x

' Turn off filter
Sheets(sht).AutoFilterMode = False

With Application
.CutCopyMode = False
.ScreenUpdating = True
End With

End Sub
 
Laatst bewerkt:
Ik heb nu een code die werkt. Echter wat mij opvalt is dat die op de sheets automatisch de kolombreedte aanpast. Moet dit nog verder bekijken. Het selecteren van de gewenste code moet uitgevonden worden. Keuze uit ongeveer 200 codes.

Als ik nu in kolom A van de sheet Maand de gewenste code waarvan een sheet moet worden aangemaakt een vulkleur geef, dan kun je het oplossen. Maar dan moet de code aangepast worden. Wie wil dit doen?

PHP: 
Sub SplitDataToSheets()
    Dim wsSource As Worksheet
    Dim wsNew As Worksheet
    Dim lastRow As Long
    Dim uniqueList As Collection
    Dim cellValue As Variant
    Dim i As Long
    
    ' Set the source worksheet (Update name if different)
    Set wsSource = ThisWorkbook.Worksheets("Maand")
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    Set uniqueList = New Collection

    ' 1. Get unique values from Column A
    On Error Resume Next
    For i = 2 To lastRow ' Assumes Row 1 is a header
        uniqueList.Add wsSource.Cells(i, 1).Value, CStr(wsSource.Cells(i, 1).Value)
    Next i
    On Error GoTo 0

    ' 2. Loop through unique values, filter, and copy to new sheets
    Application.ScreenUpdating = False
    For Each cellValue In uniqueList
        ' Create new sheet or use existing one
        On Error Resume Next
        Set wsNew = Sheets(CStr(cellValue))
        If wsNew Is Nothing Then
            Set wsNew = Sheets.Add(After:=Sheets(Sheets.Count))
            wsNew.Name = CStr(cellValue)
        Else
            wsNew.Cells.Clear
        End If
        On Error GoTo 0
        
        ' Filter source data and copy visible cells
        wsSource.Range("A1").AutoFilter Field:=1, Criteria1:=cellValue
        wsSource.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=wsNew.Range("A1")
        wsNew.Columns.AutoFit
        
        Set wsNew = Nothing
    Next cellValue

    ' Clean up
    wsSource.AutoFilterMode = False
    wsSource.Activate
    Application.ScreenUpdating = True
    MsgBox "Sheets created successfully!", vbInformation
End Sub
 
Laatst bewerkt:
Voor de kolombreedte.
Code: 
Sheets.Add(after:=Sheets(Sheets.Count)).Name = x.Value
With ActiveSheet.Cells(1)
   .PasteSpecial xlPasteAll  '-4104
   .PasteSpecial xlPasteColumnWidths  '8
End With
 
Ik denk voeg een criterium toe:
wsSource.Range("A1").AutoFilter Field:=1, Criteria1:=cellValue, Criteria2:=RGB(0, 176, 240)

helaas werkt niet.
Code: 
Sub SplitDataToSheets()
    Dim wsSource As Worksheet
    Dim wsNew As Worksheet
    Dim lastRow As Long
    Dim uniqueList As Collection
    Dim cellValue As Variant
    Dim i As Long
    
    ' Set the source worksheet (Update name if different)
    Set wsSource = ThisWorkbook.Worksheets("Maand")
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    Set uniqueList = New Collection

    ' 1. Get unique values from Column A
    On Error Resume Next
    For i = 2 To lastRow ' Assumes Row 1 is a header
        uniqueList.Add wsSource.Cells(i, 1).Value, CStr(wsSource.Cells(i, 1).Value)
    Next i
    On Error GoTo 0

    ' 2. Loop through unique values, filter, and copy to new sheets
    Application.ScreenUpdating = False
    For Each cellValue In uniqueList
        ' Create new sheet or use existing one
        On Error Resume Next
        Set wsNew = Sheets(CStr(cellValue))
        If wsNew Is Nothing Then
            Set wsNew = Sheets.Add(After:=Sheets(Sheets.Count))
            wsNew.Name = CStr(cellValue)
        Else
            wsNew.Cells.Clear
        End If
        On Error GoTo 0
        
        ' Filter source data and copy visible cells
        wsSource.Range("A1").AutoFilter Field:=1, Criteria1:=cellValue, Operator:=xlAnd, Criteria2:=RGB(0, 176, 240)
    End With
End Sub

Belangrijke onderdelen:

    Range("A1:C100"): Het bereik dat je wilt filteren. Zorg ervoor dat de headers in de eerste rij van dit bereik staan.
    Field:=x: Het kolomnummer (vanaf links, 1 = A, 2 = B, etc.).
    Criteria1:="Waarde": De eerste voorwaarde.
    Operator:=xlAnd: Combineert Criteria1 en Criteria2 met een 'EN'-voorwaarde (beide moeten waar zijn).
    Operator:=xlOr: Combineert met een 'OF'-voorwaarde (één van beide moet waar zijn).
    Operator:=xlFilterValues: Gebruikt Criteria1 als een matrix (Array) om meerdere waarden te selecteren.
    Criteria2:="Waarde": De tweede voorwaarde.

Om filters te wissen:
VBA

Sub WisFilters()
    ThisWorkbook.Sheets("Blad1").AutoFilterMode = False
End Sub

    Hoe filter je met meerdere criteria in Excel VBA?
    23 aug 2025 — Hoe kan ik meerdere waarden in één kolom filteren met VBA? Gebruik AutoFilter met een matrix: Field:=1, Criteria1:=Arra...

                                        Field:=1, Criteria2:=RGB(0, 176, 240)
        wsSource.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=wsNew.Range("A1")
        wsNew.Columns.AutoFit
        
        Set wsNew = Nothing
    Next cellValue

    ' Clean up
    wsSource.AutoFilterMode = False
    wsSource.Activate
    Application.ScreenUpdating = True
    MsgBox "Sheets created successfully!", vbInformation
End Sub
 
Laatst bewerkt:
Je hoeft geen tweede blad te maken, geen gegevens te kopiëren, doch slechts de gefilterde data als PDF op te slaan.

Code: 
For each it in columns(1)
   it.currentregion.autofilter 1,it
   activeworkbook.saveasfixedformat 0,"G:\OF\voorbeeld.pdf"
   it.currentregion.autofilter
next
 
Als pdf opslaan is niet meer de vraag. Dat werkt in de praktijk niet omdat de pdf een totaal verkeerde preview geeft. Ik moet nu de alleen nog de juiste code hebben die de sheets aanmaakt op basis van twee criteria. Dit lukt niet.

Dus ik wil code U900 als filter/sheet dan maak ik in kolom A deze code blauw.
Maar ik wil ook een filter van code/filter 8400 dan maak ik ook die blauw. Dus codes die blauw zijn wil ik een apart filter van. Twee sheets U900 en 8400.
 

Bijlagen

Laatst bewerkt door een moderator:
Als je mijn code gebruikt komt de pdf er wel goed uit te zien.
Vergeet die kleuren. maar maak gebruik van autofilter:

Code: 
Sub M_snb()
    Cells(1).CurrentRegion.AutoFilter 1, Array("8400", "U103"), 7
End Sub
 
Zonder documenten waar de code in staat is het onmogelijk nog verder te werken. Ben gisteren begonnen en heb zorgvuldig geformuleerd en wensen duidelijk gemaakt en praktische zaken direct doorgegeven. Als ik 10 uur en meer over een vraag/probleem moet doen dan is dat niet goed. Ben al half blind.

Compileerfout.jpg
 
Laatst bewerkt:
Senso zei:
Ik denk voeg een criterium toe:
wsSource.Range("A1").AutoFilter Field:=1, Criteria1:=cellValue, Criteria2:=RGB(0, 176, 240)
helaas werkt niet.
Klik om te vergroten...
RGB(0, 176, 240) is gelijk aan 15773696
Dat zie ik nergens in kolom A.
 
Je moet ingelogd zijn om te kunnen reageren. Log in | Registreer
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan