Microsoft Excel

Excel und VBA: Formeln, Programmierung, Lösungen

Die Excel/VBA-Beispiele

Thema

Dialoggesteuerte Druckmehrblattauswahl

Gruppe

UserForm

Problem

Wenn ich mehrere Arbeitsblätter auswähle und den Druckbefehl gebe wird mir in der Kopfzeile als Gesamtzahl der Blätter die Gesamtzahl der Druckseiten aller ausgewählten Arbeitsblätter ausgegeben. Wie kann ich das auf die Seiten des jeweiligen Arbeitsblattes beschränken?

Lösung
Geben Sie den nachfolgenden Code in ein Standardmodul ein und weisen Sie ihn einer Schaltfläche zu.

StandardModule: basMain

Sub PrintSheets()
   Dim frmNew As Object
   Dim wks As Worksheet
   Dim chb As MSForms.CheckBox
   Dim cmd As MSForms.CommandButton
   Dim arr() As String
   Dim iCounter As Integer, iDrive As Integer
   Dim iTop As Integer
   Dim sCode As String
   Application.VBE.MainWindow.Visible = False
   On Error Resume Next
   Set frmNew = ThisWorkbook.VBProject.VBComponents("frmWks")
   If Err = 0 Then GoTo ERRORHANDLER
   On Error GoTo 0
   Set frmNew = ThisWorkbook.VBProject.VBComponents.Add(3)
   iTop = 5
   For Each wks In Worksheets
      Set chb = frmNew.Designer.Controls.Add("forms.CheckBox.1")
      With chb
         .Top = iTop
         .Left = 5
         .Width = 100
         .Caption = "Blatt " & wks.Name
      End With
      iTop = iTop + 20
   Next wks
   Set cmd = frmNew.Designer.Controls.Add("forms.CommandButton.1")
   With cmd
      .Top = iTop
      .Left = 5
      .Width = 100
      .Height = 25
      .Caption = "OK"
      .Name = "cmdOK"
   End With
   iTop = iTop + 30
   Set cmd = frmNew.Designer.Controls.Add("forms.CommandButton.1")
   With cmd
      .Top = iTop
      .Left = 5
      .Width = 100
      .Height = 25
      .Caption = "Abbrechen"
      .Name = "cmdCancel"
   End With
   With frmNew
      .Properties("Width") = 118
      .Properties("Height") = iTop + 50
      .Properties("Caption") = "Arbeitsblätter"
      .Properties("Name") = "frmWks"
   End With
   sCode = "Private Sub cmdCancel_Click" & vbLf
   sCode = sCode & "   Unload Me" & vbLf
   sCode = sCode & "End Sub" & vbLf & vbLf
   sCode = sCode & "Private Sub cmdOK_Click" & vbLf
   sCode = sCode & "   Dim arr() as String" & vbLf
   sCode = sCode & "   Dim iArr as Integer" & vbLf
   sCode = sCode & "   Dim iCounter As Integer" & vbLf
   sCode = sCode & "   For iCounter = 1 to " & Worksheets.Count & vbLf
   sCode = sCode & "      If Controls(""CheckBox"" & iCounter).Value"
   sCode = sCode & " = True Then" & vbLf
   sCode = sCode & "         iArr = iArr + 1" & vbLf
   sCode = sCode & "         Redim Preserve arr(1 to iArr)" & vbLf
   sCode = sCode & "         arr(iArr) = Worksheets(iCounter).Name" & vbLf
   sCode = sCode & "      End If" & vbLf
   sCode = sCode & "   Next iCounter" & vbLf
   sCode = sCode & "   If iArr > 0 Then" & vbLf
   sCode = sCode & "      Unload Me" & vbLf
   sCode = sCode & "      For iCounter = 1 to iArr" & vbLf
   sCode = sCode & "         Worksheets(arr(iCounter)).PrintPreview" & vbLf
   sCode = sCode & "      Next iCounter" & vbLf
   sCode = sCode & "   Else" & vbLf
   sCode = sCode & "      Unload Me" & vbLf
   sCode = sCode & "   End If" & vbLf
   sCode = sCode & "End Sub" & vbLf
   ThisWorkbook.VBProject.VBComponents("frmWks").CodeModule.AddFromString sCode
ERRORHANDLER:
   VBA.UserForms.Add(frmNew.Name).Show
   ThisWorkbook.VBProject.VBComponents.Remove ThisWorkbook.VBProject.VBComponents(frmNew.Name)
   Set frmNew = Nothing
   Exit Sub
End Sub