Automatisieren: Filtern, PDF speichern usw.

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Marzena,
Daten beginnen in A1 (Überschriften), die PDF's werden im Verzeichnis der Datei gespeichert, Tabellenname im Code anpassen.

' **********************************************************************
' Modul: Modul3  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub FilterAndSavePDF()
Dim vntFilter As Variant, vntItem As Variant


On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .Calculation = xlManual
  .DisplayAlerts = False
End With

With Sheets("Tabelle6") 'Tabellenname - Anpassen!
  If .FilterMode Then .ShowAllData
  vntFilter = .Range("C2:C" & Application.Max(2, .Cells(.Rows.Count, 3).End(xlUp).Row))
  vntFilter = toArraySorted(vntFilter)
  For Each vntItem In vntFilter
    .Range("A1").CurrentRegion.AutoFilter Field:=3, Criteria1:=vntItem, Operator:=xlAnd
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & vntItem & ".pdf"
  Next
End With

ErrExit:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'FilterAndSavePDF'" & vbLf & String(60, "_") & _
      vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
      "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
      .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
      "VBA - Fehler in Prozedur - FilterAndSavePDF"
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = xlAutomatic
  .DisplayAlerts = True
  .StatusBar = False
End With

End Sub


Public Function toArraySorted(Field As Variant, Optional Uniqe As Boolean = True) As Variant
Dim objArrayList As Object
Dim lngR As Long, lngC As Long

On Error GoTo ErrExit

Set objArrayList = CreateObject("System.Collections.Arraylist")

With objArrayList
  For lngR = LBound(Field, 1) To UBound(Field, 1)
    For lngC = LBound(Field, 2) To UBound(Field, 2)
      If Not .Contains(Trim(Field(lngR, lngC))) Or Not Uniqe Then
        If Field(lngR, lngC) <> "" Then .Add Trim(Field(lngR, lngC))
      End If
    Next
  Next
  .Sort
  toArraySorted = .toArray
End With

Exit Function
ErrExit:
toArraySorted = -1
End Function

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Automatisieren: Filtern, PDF speichern usw.

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread