AW: zeig doch mal den Code! o.T.
13.06.2011 18:30:41
Heinz
Hallo Sepp
Das erste Makro wurde mir von Franz (fcs) entworfen und wird von mir mit FreePDF genutzt.
Das zweite Makro habe ich mir agepasst für das Office PDF-tool.
Das erste Blatt in der Tabelle heißt "Inhaltsverzeichnis" und hat in Spalte A Hyperlinks mit den Tabellennamen (erzeugt durch Addin von Bernd Augustin "Inhaltsverzeichnis")
In Spalte B kann ich mir die zu druckenden Tabellenblätter mit x auswählen.
Wie bereits gesagt - funktionierte in Excel 2007 perfekt, funkioniert auch noch in 2010 (Makros werden ausgeführt), aber beim erneuten Öffenen der Exceldatei kommt die nicht mehr wegklickbare Meldung
wie oben beschrieben ("Objekte können nicht über das Blatt hinaus verschoben werden"
Viele Grüße
Heinz Wilhelm
Sub BlaetterDrucken_mit_Inhaltsverzeichnis_H2_x()
'Die folgende Prozedur kannst Du z.B. per Buttonklick starten,
'die Blätter der in Spalte B mit "x" markierten Blätter werden gedruckt.
Dim wks As Worksheet, Zeile As Long, lNr As Long, _
strDrucker As String, arrZeilen() As Long, arrBlatt() As String
lNr = 0
If MsgBox("Blätter in mit ""x"" markierten Zeilen Drucken?", vbQuestion + vbYesNo, _
"Blätter Drucken") = vbYes Then
'Daten der zu druckenden Blätter einlesen
Set wks = Worksheets(1) ' = Worksheets("Inhalt")
With wks
For Zeile = 3 To .Cells(.Rows.Count, 2).End(xlUp).Row
If LCase(.Cells(Zeile, 2)) = "x" And _
fncCheckSheet(ActiveWorkbook, Worksheets(1).Cells(Zeile, 1).Text) = True Then
lNr = lNr + 1
ReDim Preserve arrZeilen(1 To lNr)
ReDim Preserve arrBlatt(1 To lNr)
arrZeilen(lNr) = Zeile
arrBlatt(lNr) = Worksheets(1).Cells(Zeile, 1)
Else
'Blatt mit Name in Spalte A ist nicht ausgewählt
Worksheets(1).Cells(Zeile, 2) = "Blatt nicht ausgewählt"
End If
Next
End With
If lNr > 0 Then
Application.ScreenUpdating = False
'Blätter drucken
strDrucker = Application.ActivePrinter 'aktiven Drucker merken
'anderen Drucker wählen aktivieren - Name ggf. mit Makrorekorder aufzeichnen
Application.ActivePrinter = "FreePDF_Multidoc auf Ne05:"
Application.DisplayAlerts = False
' ActiveWorkbook.Sheets(arrBlatt).PrintPreview
ActiveWorkbook.Sheets(arrBlatt).PrintOut
Application.DisplayAlerts = True
Application.ActivePrinter = strDrucker 'gemerkten Drucker wieder aktivieren
Application.ScreenUpdating = True
End If
End If
End Sub
Function fncCheckSheet(wb As Workbook, varBlatt) As Boolean
'Prüft ob Blatt in Arbeitsmappe vorhanden
'Gehört zum obenstehenden
Sub BlaetterDrucken ().
Dim objSheet As Object
For Each objSheet In wb.Sheets
If objSheet.Index = varBlatt Or LCase(objSheet.Name) = LCase(varBlatt) Then
fncCheckSheet = True
Exit For
End If
Next
End Function
Sub BlaetterDrucken_mit_Inhaltsverzeichnis_H3_x()
'Die folgende Prozedur kannst Du z.B. per Buttonklick starten,
'die Blätter der in Spalte B mit "x" markierten Blätter werden als PDF gedruckt.
Dim wks As Worksheet, Zeile As Long, lNr As Long, _
strDrucker As String, arrZeilen() As Long, arrBlatt() As String
lNr = 0
If MsgBox("Blätter in mit ""x"" markierten Zeilen als PDF veröffentlichen?", vbQuestion + _
vbYesNo, _
"Blätter Drucken") = vbYes Then
'Daten der zu druckenden Blätter einlesen
Set wks = Worksheets(1) ' = Worksheets("Inhalt")
With wks
For Zeile = 3 To .Cells(.Rows.Count, 2).End(xlUp).Row
If LCase(.Cells(Zeile, 2)) = "x" And _
fncCheckSheet(ActiveWorkbook, Worksheets(1).Cells(Zeile, 1).Text) = True Then
lNr = lNr + 1
ReDim Preserve arrZeilen(1 To lNr)
ReDim Preserve arrBlatt(1 To lNr)
arrZeilen(lNr) = Zeile
arrBlatt(lNr) = Worksheets(1).Cells(Zeile, 1)
Else
'Blatt mit Name in Spalte A ist nicht ausgewählt
Worksheets(1).Cells(Zeile, 2) = "Blatt nicht ausgewählt"
End If
Next
End With
If lNr > 0 Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveWorkbook.Sheets(arrBlatt).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
Worksheets("Verknüpfung_1").Range("B2") & "_" & ActiveSheet.Range("A3") & "_MS" & ".pdf" _
, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
End If
Sheets("Inhaltsverzeichnis").Select
Range("A2").Select
End Sub
Function fncCheckSheet(wb As Workbook, varBlatt) As Boolean
'Prüft ob Blatt in Arbeitsmappe vorhanden
'Gehört zum obenstehenden
Sub BlaetterDrucken ().
Dim objSheet As Object
For Each objSheet In wb.Sheets
If objSheet.Index = varBlatt Or LCase(objSheet.Name) = LCase(varBlatt) Then
fncCheckSheet = True
Exit For
End If
Next
End Function