AW: Drucken mit vba & Abfrage nach Tabellenblatt
13.01.2015 19:35:07
fcs
Hallo Dominic,
bei dir war die Auswertung der MsgBox mit Ja/Nein-Schaltflächen nicht korrekt und die End Ifs muss man auch anders setzen.
Außerdem sollte der Wert in M1 für die Prüfung gerundet werden, denn 0,9999 ist immer noch kleiner 1.
Das Blatt "Gesamt" muss vor der For-Next-Schleife als 1. Element in das Array für die zu druckenden Blätter eingefügt werden.
Gruß
Franz
Sub Drucken_P_Blaetter()
Dim arrSheets() As String, intNr As Integer, intS As Integer, objSheet As Object
Dim objSheetAktiv As Object
Dim varAnzahl
Dim byWert As Byte
On Error GoTo Fehler
If Sheets("Gesamt").Range("M3") = "Ja" _
And VBA.Round(Sheets("Gesamt").Range("M1"), 3) =99,95% = OK
byWert = MsgBox( _
"Es gibt einen Fehler bei der Umlage der monatlichen Gebühr." _
& vbCrLf & vbCrLf _
& "Bitte prüfen Sie die jew. Produkt Anteiligkeit - zu finden jeweils in " _
& "Zelle C37 - da die Summer der Anteile aktuell bei unter 100% liegt!" _
& vbCrLf & vbCrLf & "Kalkulation dennoch ausdrucken?", _
4, "Plausibilitätsprüfung fehlgeschlagen") '4 = vbYesNo
If byWert = 7 Then '7 = vbNo
MsgBox "Der Druck wird nicht ausgeführt"
GoTo Fehler
ElseIf byWert = 6 Then ' 6 = vbYes
'do nothing - macht nach End If weiter
Else
GoTo Fehler
End If
End If
Eingabe_Anzahl:
varAnzahl = Application.InputBox( _
Prompt:="Wie viele Rechnungsblätter sollen gedruckt werden (1 bis 10)?", _
Title:="Rechnungsblätter gruppiert drucken", _
Default:=1, _
Type:=1)
Select Case varAnzahl
Case 0
'Eingabe wurde abgebrochen oder 0 eingegeben
Case 1 To 10
Set objSheetAktiv = ActiveSheet 'aktives Blatt merken
Set objSheet = ActiveWorkbook.Sheets("Gesamt")
intS = intS + 1
ReDim Preserve arrSheets(1 To intS)
arrSheets(intS) = objSheet.Name
'Seite einrichten Blatt "Gesamt"
With objSheet.PageSetup
.Zoom = False
.PrintArea = "$A$1:$G$54"
.Orientation = xlPortrait
.PaperSize = xlPaperA4
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
For intNr = 1 To varAnzahl
Set objSheet = ActiveWorkbook.Sheets("P" & Format(intNr, "0"))
intS = intS + 1
ReDim Preserve arrSheets(1 To intS)
arrSheets(intS) = objSheet.Name
'Seite einrichten Blatt
With objSheet.PageSetup
.Zoom = False
.PrintArea = "$A$1:$G$54"
.Orientation = xlPortrait
.PaperSize = xlPaperA4
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Next_intNr:
Next
ActiveWorkbook.Sheets(arrSheets).Select
Application.Dialogs(xlDialogPrint).Show
objSheetAktiv.Select
Case Else
If MsgBox("unzulässiger Wert für die Anzahl zu druckender Rechnungsblätter", _
vbInformation + vbRetryCancel, "Drucken Rechnungsblätter") = vbRetry Then
GoTo Eingabe_Anzahl
End If
End Select
Fehler:
With Err
Select Case .Number
Case 0 'alles Ok
Case 9 'Index-Fehler - Blatt mit Name "P" & intNr existiert nicht
Resume Next_intNr
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub