Aus Excel-File PDF erstellen
Meier
Ich brauche wieder einmal heure wertvolle Hilfe. Durch google und sonstige Beiträge habe ich es leide alleine geschafft.
Ich habe ein File mit über 50 Registern. Damit ich die jweiligen Abteilungsfiles erstellen kann, habe ich mir dann ein VBA-Code geschrieben, der einn eues Excel-File generiert mit nur den Abteilungsregistern. Ich sollte aber das selbe noch als PDF haben.
Kann mir jemand helfen, folgendes Makro so umzuschreiben, dass darus PDF's erzeugt werden? Ich benütze den Adobe Acrobat 9 pro.
Vielen Dank für eure Hilfe.
Sub Abteilungsfiles_Erstellen()
Dim Eingabewert As Byte
Eingabewert = MsgBox("Files erstellen aus Reporting_alle-File und nicht aus ursprünglichem _
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
'Test 1 - 3
neudatei = strFilename & "Test1" & ".xls"
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile Pfad & "\" & aktdatei, _
Pfad & "\" & neudatei, True
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & neudatei
'Verschiebt Blätter Kanton hinter das letzte Sheet
i = ThisWorkbook.Worksheets.Count
ActiveWorkbook.Sheets("KtLuzern_Quartal").Move After:=Sheets(i)
ActiveWorkbook.Worksheets("KtLuzern_Monat").Move After:=Sheets(i)
ActiveWorkbook.Worksheets("Infos").Move After:=Sheets(i)
'ActiveWorkbook.Worksheets("Test1").Delete
'ActiveWorkbook.Worksheets("Test2").Delete
'ActiveWorkbook.Worksheets("Test3").Delete
ActiveWorkbook.Worksheets("Test4").Delete
ActiveWorkbook.Worksheets("Test5").Delete
ActiveWorkbook.Worksheets("Test6").Delete
ActiveWorkbook.Worksheets("Test1").Activate
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
ActiveWorkbook.Save
ActiveWorkbook.Close
'Test 4 - 6
neudatei = strFilename & "Test4" & ".xls"
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile Pfad & "\" & aktdatei, _
Pfad & "\" & neudatei, True
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & neudatei
'Verschiebt Blätter Kanton hinter das letzte Sheet
i = ThisWorkbook.Worksheets.Count
ActiveWorkbook.Sheets("KtLuzern_Quartal").Move After:=Sheets(i)
ActiveWorkbook.Worksheets("KtLuzern_Monat").Move After:=Sheets(i)
ActiveWorkbook.Worksheets("Infos").Move After:=Sheets(i)
ActiveWorkbook.Worksheets("Test1").Delete
ActiveWorkbook.Worksheets("Test2").Delete
ActiveWorkbook.Worksheets("Test3").Delete
'ActiveWorkbook.Worksheets("Test4").Delete
'ActiveWorkbook.Worksheets("Test5").Delete
'ActiveWorkbook.Worksheets("Test6").Delete
ActiveWorkbook.Worksheets("Test4").Activate
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
ActiveWorkbook.Save
ActiveWorkbook.Close
'Nachfrage und Anzeige wieder aktivieren
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
MsgBox "Alle Files erstellt"
End Sub