Tabellenblätter in PDF

Forumthread: Tabellenblätter in PDF

03.07.2017 14:57:15

Jens

Guten Tag,
einmal im Monat muss folgende "Tätigkeit" ausführen:
1) Alle Excel-Dateien in einem Ordner öffnen (ca. 30 Stück).
2) Das jeweils erste Tabellenblatt als PDF unter dem Namen der Excel-Datei im selben Ordner abspeichern.
3) Alle Excel Dateien wieder schließen.
Es ist möglich, diesen Vorgang mit einem Makro zu erledigen?
Für jede Unterstützung wäre ich sehr dankbar.
Gruß
Jens

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Tabellenblätter in PDF

03.07.2017 15:21:16

UweD
SUPER! zwei Rückfragen

03.07.2017 16:24:34

Jens
AW: SUPER! zwei Rückfragen

03.07.2017 16:38:03

UweD
Klasse & Dank owT

03.07.2017 17:20:09

Jens
AW: SUPER! zwei Rückfragen

03.07.2017 16:49:17

UweD

AW: Tabellenblätter in PDF

03.07.2017 15:21:16

UweD

Hallo
so?

Sub alle_Dateien_Verzeichnis() ' 
    On Error GoTo Fehler
    Dim Pfad$, Ext$, Datei$, NeuName$
    
    Ext = "*.xls*"
    Pfad = "C:\Temp\" '**** mit \ 
    
    Datei = Dir(Pfad & Ext)
    Do While Len(Datei) > 0
        NeuName = Left(Datei, InStr(Datei, ".") - 1)
        Workbooks.Open Filename:=Pfad & Datei
        '** 
        ActiveWorkbook.Sheets(1).ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=Pfad & NeuName & ".pdf", Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
        '** 
        Workbooks(Datei).Close False
        
        Datei = Dir() ' nächste Datei 
    Loop
    
    
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear

End Sub

LG UweD

SUPER! zwei Rückfragen

03.07.2017 16:24:34

Jens

Hallo Uwe,
ich bin zutiefst beeindruckt, wie effizient Dein Makro arbeitet und mit so wenigen Zeilen auskommt.
Nun werde ich ein wenig gierig:
1) Ist es möglich, den Pfad in der Excel-Steuerdatei in einer Zelle zu hinterlegen und diese Zelle dann "auszulesen" (z.B.: über einen Zellnamen)?
2) Bei wenigen Dateien kommt beim Makrolauf die Box: "soll die Datei aktualisiert werden". Es ist kein Problem diese Meldung einfach wegzudrücken, aber perfekt wäre eine automatische Unterdrückung, falls dies möglich ist. Eine Aktualisierung soll nicht durchgeführt werden.
Ich bedanke mich ganz herzlich für Deine tolle Unterstützung, erspart mir sehr viel Zeit.
Gruß
Jens

AW: SUPER! zwei Rückfragen

03.07.2017 16:38:03

UweD

Hallo
1)
- hier mal ein Beispiel für einen Zellbezug.
- mit Prüfung
2)
durch die Angabe des Parameters , UpdateLinks:=False (oder true)

Sub alle_Dateien_Verzeichnis() ' 
    On Error GoTo Fehler
    Dim Pfad$, Ext$, Datei$, NeuName$
    
    Ext = "*.xls*"
    
    Pfad = Sheets("Parameter").Range("A2") '**** mit \ 
    If Dir(Pfad, vbDirectory) = "" Then
        MsgBox "Pfad nicht vorhanden"
    End If
    
    Datei = Dir(Pfad & Ext)
    Do While Len(Datei) > 0
        NeuName = Left(Datei, InStr(Datei, ".") - 1)
        Workbooks.Open Filename:=Pfad & Datei, UpdateLinks:=False
        '** 
        ActiveWorkbook.Sheets(1).ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=Pfad & NeuName & ".pdf", Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
        '** 
        Workbooks(Datei).Close False
        
        Datei = Dir() ' nächste Datei 
    Loop
    
    
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear

End Sub

LG UweD

Klasse & Dank owT

03.07.2017 17:20:09

Jens

AW: SUPER! zwei Rückfragen

03.07.2017 16:49:17

UweD

Hier noch mit Verbesserungen

Sub alle_Dateien_Verzeichnis() ' 
    On Error GoTo Fehler
    Dim Pfad$, Ext$, Datei$, NeuName$
    
    Ext = "*.xls*"
    
    Pfad = Range("Dateipfad") ' vergebener Name 
    Pfad = IIf(Right(Pfad, 1) = "\", Pfad, Pfad & "\") ' prüfen, ob \ am Ende 
    
    If Dir(Pfad, vbDirectory) = "" Then ' prüfen, ob Verzeichnis existiert 
        MsgBox "Pfad nicht vorhanden"
        Exit Sub
    End If
    
    Datei = Dir(Pfad & Ext)
    Do While Len(Datei) > 0
        NeuName = Left(Datei, InStr(Datei, ".") - 1)
        Workbooks.Open Filename:=Pfad & Datei, UpdateLinks:=False
        '** 
        ActiveWorkbook.Sheets(1).ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=Pfad & NeuName & ".pdf", Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
        '** 
        Workbooks(Datei).Close False
        
        Datei = Dir() ' nächste Datei 
    Loop
    
    
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear

End Sub

LG UweD

Beliebteste Forumthreads (12 Monate)

Forumthread: Tabellenblätter in PDF

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread