Makro - Speichern unter als PDF
25.03.2013 11:34:45
Meier
Wieder einmal benötige ich Eure super Hilfe. Ich habe ein bestehendes Makro, dass mir aus einer Excel-Datei, verschiedene Excel mit den richtigen Registern ausgibt, sowie korrekte Bennenung.
Jetzt benötige ich das selbe Makro, dass mir aber keine Excel's, sondern PDF's ausgibt.
Besten Dank für die Hilfe, bzw Anpassung meines Makros.
Sub PDF-Files_erstellen()
Dim Eingabewert As Byte
Eingabewert = MsgBox("Files erstellen aus Reporting_alle-File. Weiterfahren?", vbYesNo + _
vbQuestion)
If Eingabewert = vbNo Then
Exit Sub
End If
'aktuelle Datei
Dim pfad As String
Dim aktdatei As String
Dim neudatei As String
Dim fs
pfad = ThisWorkbook.Path
aktdatei = ThisWorkbook.Name
'Jahr, Monat bestimmen
Dim strFilenameYear As String
strFilenameYear = InputBox("Jahr", "", DateTime.Year(DateTime.Now))
Dim strFilenameMonat As String
strFilenameMonat = InputBox("Monat", "", DateTime.Month(DateTime.Now) - 1)
If Len(strFilenameMonat) = 1 Then
strFilenameMonat = "0" & strFilenameMonat
End If
'Dateiname erster Teil setzen
Dim strFilename As String
strFilename = "Reporting_" & strFilenameYear & "_" & strFilenameMonat & "_"
'Nachfrage und Anzeige unterdrücken
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Abteilung 1
neudatei = strFilename & "Abteilung1" & ".xlsm"
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile pfad & "\" & aktdatei, _
pfad & "\" & neudatei, True
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & neudatei
'Verschiebt Register
i = ThisWorkbook.Worksheets.Count
ActiveWorkbook.Sheets("KtLuzern_Quartal").Move After:=Sheets(i)
ActiveWorkbook.Worksheets("Tabelle1").Move After:=Sheets(i)
ActiveWorkbook.Worksheets("Tabelle2").Move After:=Sheets(i)
ActiveWorkbook.Worksheets("Tabelle1").Delete
ActiveWorkbook.Worksheets("Tabelle2").Delete
ActiveWorkbook.Worksheets("Tabelle3").Delete
ActiveWorkbook.Worksheets("Tabelle4").Delete
ActiveWorkbook.Worksheets("Tabelle5").Delete
ActiveWorkbook.Worksheets("Tabelle6").Delete
'ActiveWorkbook.Worksheets("Tabelle7").Delete
'ActiveWorkbook.Worksheets("Tabelle8").Delete
'ActiveWorkbook.Worksheets("Tabelle9").Delete
ActiveWorkbook.Worksheets("Tabelle1").Activate
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
MsgBox "Alle Files erstellt"
End Sub