Mit Formaten...
08.11.2017 14:02:19
Michael
...so
Sub a()
Dim WbQ As Workbook: Set WbQ = ThisWorkbook
Dim WbZ As Workbook
Dim WsQ As Worksheet: Set WsQ = WbQ.Worksheets("Tabelle1")
Dim WsZ As Worksheet, r As Range
Dim a, aL As Object, i&, Pfad$
Application.ScreenUpdating = False
Pfad = WbQ.Path & "\"
Set aL = CreateObject("System.Collections.ArrayList")
With WsQ
If .AutoFilterMode Then .AutoFilterMode = False
.Range("A1").EntireRow.Insert xlDown
a = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
For i = LBound(a) To UBound(a)
If Not aL.contains(a(i, 1)) Then aL.Add a(i, 1)
Next i
Set r = .Range("A1:F" & .Cells(.Rows.Count, 1).End(xlUp).Row)
With r
For i = 0 To aL.Count - 1
WsQ.AutoFilterMode = False
.AutoFilter field:=1, Criteria1:=aL.Item(i)
WsQ.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
Set WbZ = Workbooks.Add(xlWBATWorksheet)
Set WsZ = WbZ.Worksheets(1)
WsZ.Cells(1, 1).PasteSpecial xlPasteValues
WsZ.Cells(1, 1).PasteSpecial xlPasteFormats
WsZ.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Pfad & aL.Item(i) & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
WbZ.Close False
Next i
.Range("A1").EntireRow.Delete xlUp
End With
.AutoFilterMode = False
End With
Set WbQ = Nothing: Set WbZ = Nothing: Set WsQ = Nothing
Set WsZ = Nothing: Set r = Nothing: Erase a: aL.Clear
End Sub
LG
Michael