AW: Tabellenblätter PDF-Datei Namen aus Zelle drucken
18.12.2017 12:56:28
Jörg
Hallo Obelix,
lege Dir ein Register "Überblick" an und lasse das Makro "Registernamen_auslesen" laufen.
Dieses schreibt Dir in Spalte A Deine 500 Registernamen rein.
Dort löscht Du die nicht benötigten Register für Dein PDF Print. Die Liste muss fortlaufend sein, da bei der ersten Leerzelle abgebrochen wird. Zelle A1 ("Überblick") darf nicht gelöscht werden.
Der PDF Datei name setzt sich wie folgt zusammen:
Zellinhalt von Zelle E1 + Registername + Zellinhalt von Zelle E12
(Hier kannst Du das Datum o.ä. eingeben)
Speicherort wird in Zelle E3 eingegeben.
Zum Schluß Makro "Mail" starten.
Tipp: erst mit 2 oder 3 Namen in Spalte A testen
Ciao Jörg
Option Explicit
Dim Text_vorne As String
Dim Text_hinten As String
Dim Speicherort As String
Dim Registername As String
Dim Registername_neu As String
Dim FileName As String
Sub Registernamen_auslesen()
Dim lngWorksheets As Long
Dim i As Long
lngWorksheets = ThisWorkbook.Worksheets.Count
For i = 1 To lngWorksheets
ThisWorkbook.Sheets("Überblick").Cells(0 + i, 1).Value = ThisWorkbook.Worksheets(i).Name
Next i
End Sub
Sub Mail()
Sheets("Überblick").Select
Text_vorne = Range("E1").Value
Text_hinten = Range("E2").Value
Speicherort = Range("E3").Value & "\"
Range("A1").Select
Zeile1:
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value = "" Then Exit Sub
Registername = ActiveCell.Value
Registername_neu = Text_vorne & Registername & Text_hinten & ".pdf"
Sheets(Registername).Select
RDB_Worksheet_Or_Worksheets_To_PDF
Sheets("Überblick").Select
GoTo Zeile1
End Sub
Sub RDB_Worksheet_Or_Worksheets_To_PDF()
'http://www.rondebruin.nl/win/s5/pdf.htm
If ActiveWindow.SelectedSheets.Count > 1 Then
MsgBox "There is more then one sheet selected," & vbNewLine & _
"be aware that every selected sheet will be published"
End If
'Call the function with the correct arguments
'Tip: You can also use Sheets("YourSheetName") instead of ActiveSheet in the code(sheet not _
have to be active then)
FileName = RDB_Create_PDF(Source:=ActiveSheet, _
FixedFilePathName:=Speicherort & Registername_neu, _
OverwriteIfFileExist:=True, _
OpenPDFAfterPublish:=False)
End Sub
'The code below are used by the macros in the other two modules
'Do not change the code in the functions in this module
Function RDB_Create_PDF(Source As Object, FixedFilePathName As String, _
OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As _
String
Dim FileFormatstr As String
Dim Fname As Variant
'Test If the Microsoft Add-in is installed
If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
& Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") "" Then
If FixedFilePathName = "" Then
'Open the GetSaveAsFilename dialog to enter a file name for the pdf
FileFormatstr = "PDF Files (*.pdf), *.pdf"
Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
Title:="Create PDF")
'If you cancel this dialog Exit the function
If Fname = False Then Exit Function
Else
Fname = FixedFilePathName
End If
'If OverwriteIfFileExist = False we test if the PDF
'already exist in the folder and Exit the function if that is True
If OverwriteIfFileExist = False Then
If Dir(Fname) "" Then Exit Function
End If
'Now the file name is correct we Publish to PDF
On Error Resume Next
Source.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=OpenPDFAfterPublish
On Error GoTo 0
'If Publish is Ok the function will return the file name
If Dir(Fname) "" Then RDB_Create_PDF = Fname
End If
End Function