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