Export automatiseren

[JEC.]

Als de data niet gesorteerd is, loopt de code ook mis. Maar dat lijkt hier niet het geval te zijn.

 

[JEC.]

Hier nog eentje met arrays. Tikkeltje langzamer dan de autofilter methode omdat de regels meerdere keren worden nagelopen, rekening houdend met een ongesorteerde lijst

Sub jecc()
 Dim ar, sq, j As Long, jj As Long, x As Long
 ar = Sheets(1).ListObjects(1).DataBodyRange
 ReDim sq(2, 0)
 
 With CreateObject("scripting.dictionary")
   For j = 1 To UBound(ar)
     If ar(j, 1) = "" Then Exit Sub
     If Not .Exists(ar(j, 1)) Then
       For jj = 1 To UBound(ar)
         If ar(j, 1) = ar(jj, 1) Then
           ReDim Preserve sq(2, x)
           sq(0, x) = ar(jj, 2)
           sq(1, x) = ar(jj, 4)
           sq(2, x) = ar(jj, 3)
           x = x + 1
         End If
       Next
       With Sheets("Bestelformulieren")
         .Range("A8:C33").ClearContents
         .Cells(8, 1).Resize(x, 3) = Application.Transpose(sq)
         .Cells(2, 1) = ar(j, 1)
         .PrintOut , , , , "Adobe PDF", , , ThisWorkbook.Path & "\" & ar(j, 1) & ".pdf"
          Erase sq: x = 0
       End With
     .Item(ar(j, 1)) = Empty
    End If
  Next
 End With
End Sub