Leider benötige ich jetzt das gleiche Makro für die Erstellung von PDF's.
Wie bekomme ich die beiden VBA-Makro unter einen Hut?
Vielen Dank für eure stetige Hilfe.
Public Sub AlsPDF()
Sheets(Array("Sheet1", "Shee2"")).Copy
With ActiveWorkbook
.ExportAsFixedFormat Type:=xltyppdf, Filename:="z:\Test.pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=False, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
.Close SaveChanges:=False
End With
End Sub
Public Sub Files_erstellen()
Dim Eingabewert As Byte
Eingabewert = MsgBox("Files erstellen aus Reporting_alle. 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 = "PCO_ST_Reporting_" & strFilenameYear & "_" & strFilenameMonat & "_"
'Nachfrage und Anzeige unterdrücken
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'File1
neudatei = strFilename & "File1" & ".xls"
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile pfad & "\" & aktdatei, _
pfad & "\" & neudatei, True
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & neudatei
ActiveWorkbook.Worksheets("Register1").Delete
ActiveWorkbook.Worksheets("Register5").Delete
'File2
neudatei = strFilename & "File2" & ".xls"
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile pfad & "\" & aktdatei, _
pfad & "\" & neudatei, True
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & neudatei
ActiveWorkbook.Worksheets("Register2").Delete
ActiveWorkbook.Worksheets("Register3").Delete
'Nachfrage und Anzeige wieder aktivieren
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
MsgBox "Alle Files erstellt"
End Sub