AW: Mehrere Tabellen gleichzeitig drucken
03.09.2013 15:34:16
fcs
Hallo Dominik,
theoretisch könnte man auch jedes Ausdrucken der Datei so steuern, dass immer nur die angekreuzten Blätter gedruckt werden.
Allerdings kann man dann nicht so einfach schnell mal ein anderes Blatt drucken.
Deshalb halte ich es für besser mit einem Makro diesen Druck speziell zu starten.
Je nachdem wo du das Makro speicherst (Datei oder pers. Makroarbeitsmappe) kannst du dann eine Schaltfläche zum Drucken in deine Datei einbauen oder in dein Excelmenüband.
Gruß
Franz
'Makro in einem allgemeinen Modul der Datei oder der persönlichen Makroarbeitsmappe
Sub Tabellen_Drucken()
Dim wkb As Workbook
Dim wksDruckliste As Worksheet
Dim arrSheets() As String, intSheet As Integer, strSheet As String
Dim lngZeile As Long
Set wkb = ActiveWorkbook
'Tabellenblatt mit Liste der Blattnamen setzen
' Set wksDruckliste = wkb.Sheets(1) '1. Registerblatt
'oder
strSheet = "Tabelle1" 'Name des Blatts mit Liste der Blätter
If CheckSheetName(strSheet, wkb) = False Then
MsgBox "Blatt """ & strSheet & """ mit Liste der Blattnamen existiert nicht!", _
vbOK + vbInformation, _
"Drucken - markierte Liste"
GoTo Beenden
End If
Set wksDruckliste = wkb.Sheets(strSheet) 'Blatt mit bestimmtem Namen
'In Spalte B mit "X" markierte Blätter in Datenarray erfassen
With wksDruckliste
For lngZeile = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If UCase(.Cells(lngZeile, 2)) = "X" Then
strSheet = .Cells(lngZeile, 1).Text
If CheckSheetName(strSheet, wkb) = True Then
intSheet = intSheet + 1
ReDim Preserve arrSheets(1 To intSheet)
arrSheets(intSheet) = strSheet
Else
If MsgBox("Blatt """ & strSheet & """ existiert nicht!" _
& vbLf & "Weitermachen?", _
vbOKCancel + vbDefaultButton2 + vbQuestion, _
"Drucken - markierte Liste") = vbCancel Then GoTo Beenden
End If
End If
Next
End With
'Markierte Blätter Drucken mit Druckvorschau
If intSheet > 0 Then
wkb.Sheets(arrSheets).PrintOut Preview:=True
Else
MsgBox "im Blatt """ & wksDruckliste.Name _
& """ sind keine Blätter in Spalte B mit ""X"" markiert!"
End If
Beenden:
Set wkb = Nothing: Set wksDruckliste = Nothing
If intSheet > 0 Then
Erase arrSheets
End If
End Sub
Public Function CheckSheetName(ByVal strSheet, Optional ByVal wkb As Workbook) As Boolean
Dim objSheet As Object
On Error GoTo Fehler
If wkb Is Nothing Then Set wkb = ActiveWorkbook
Set objSheet = wkb.Sheets(strSheet)
CheckSheetName = True
Exit Function
Fehler:
End Function