Mehrfach drucken mit wenn dann VBA

[Stoffo]

Hallo zusammen,

ich habe folgendes Makro:

Code:

Option Explicit
Sub prcDrucken()
   Dim lngC As Long
  
   For lngC = 2 To 39
      With Worksheets(lngC)
         Select Case lngC
            Case 2 To 4
               With .PageSetup
                  .Orientation = xlPortrait
                  .FitToPagesWide = 1
                  .Zoom = False
                  .PrintArea = "$A$1:$E$49"
               End With
               .PrintOut Copies:=1
            Case 5 To 14
               If WorksheetFunction.CountA(.Range("A23:E44"), .Range("E3:E19")) Then
                  With .PageSetup
                     .Orientation = xlPortrait
                     .FitToPagesWide = 1
                     .Zoom = False
                     .PrintArea = "$A$1:$E$51"
                  End With
                  .PrintOut Copies:=1
               End If
               If WorksheetFunction.CountA(.Range("E3:E19"), .Range("A23:E44")) Then
                  .PageSetup.PrintArea = "$A$100:$E$151"
                  .PrintOut Copies:=2
               End If
            Case 15 To 39
               If WorksheetFunction.CountA(.Range("A23:E44")) Then
                  With .PageSetup
                     .Orientation = xlPortrait
                     .FitToPagesWide = 1
                     .Zoom = False
                     .PrintArea = "$A$1:$E$51"
                  End With
                  .PrintOut Copies:=1
                  If WorksheetFunction.CountA(.Range("A1:E51")) Then
                     .PageSetup.PrintArea = "$A$100:$E$150"
                     .PrintOut Copies:=2
                  End If
               End If
         End Select
      End With
   Next lngC

End Sub

Kurze Erklärung des bisherigen Makros:

1.Es druckt aktuell die Tabellen 2 bis 4 jeweils einmal aus. Hier nur den Bereich A1:E49 und alles auf einer Seite.
2.Die Tabellen 5 bis 14 werden nur gedruckt wenn in dem Bereich A23:E44 etwas steht oder im Bereich E3:E19. Sofern darin etwas steht wird der Bereich $A$1:$E$51 einmal und der Bereich $A$100:$E$151 zweimal ausgedruckt.
3.Die Tabellen 15 bis 39 werden nur gedruckt wenn in dem Bereich A23:E44 etwas steht. Sofern darin etwas steht wird der Bereich $A$1:$E$51 einmal und der Bereich $A$100:$E$151 zweimal ausgedruckt.

Dieses möchte ich gerne wie folgt abgeändert haben:

Wenn in den Fällen 5 bis 14 oder 15 bis 39 in Zelle E6 "XX" steht soll Der Bereich $A$100:$E$151 einmal ausgedruckt werden, wenn in E6 in den benannten Fällen in der Zelle "YY" steht soll der Bereich $A$100:$E$151 zweimal ausgedruckt werden. Alle anderen Bestandteile des Makros sollen unverändert bleiben... Nun meine Frage: Wie bekomme ich soetwas hin und hat evtl. jemand einen funktionierenden Vorschlag für mich? Bin leider was VBA angeht absoluter Anfänger und bin froh dass dieses Makro in der Form schon seine Dienste tut, leider wird so noch viel überschüssiges Papier gedruckt, welches ich nun auf diesem Wege versuche zu reduzieren.

Vielen Dank für jegliche Unterstützung.

[Kuwer]

Hallo Stoffo,

Sub prcDrucken()

   Dim lngC As Long

  

   For lngC = 2 To 39

      With Worksheets(lngC)

         Select Case lngC

            Case 2 To 4

               With .PageSetup

                  .Orientation = xlPortrait

                  .FitToPagesWide = 1

                  .Zoom = False

                  .PrintArea = "$A$1:$E$49"

               End With

               .PrintOut Copies:=1

            Case 5 To 14

               If WorksheetFunction.CountA(.Range("A23:E44"), .Range("E3:E19")) Then

                  With .PageSetup

                     .Orientation = xlPortrait

                     .FitToPagesWide = 1

                     .Zoom = False

                     .PrintArea = "$A$1:$E$51"

                  End With

                  .PrintOut Copies:=1

               End If

               If WorksheetFunction.CountA(.Range("E3:E19"), .Range("A23:E44")) Then

                  .PageSetup.PrintArea = "$A$100:$E$151"

                  .PrintOut Copies:=Switch(.Range("E6").Value = "XX", 1, .Range("E6").Value = "YY", 2)

               End If

            Case 15 To 39

               If WorksheetFunction.CountA(.Range("A23:E44")) Then

                  With .PageSetup

                     .Orientation = xlPortrait

                     .FitToPagesWide = 1

                     .Zoom = False

                     .PrintArea = "$A$1:$E$51"

                  End With

                  .PrintOut Copies:=1

                  If WorksheetFunction.CountA(.Range("A1:E51")) Then

                     .PageSetup.PrintArea = "$A$100:$E$150"

                     .PrintOut Copies:=Switch(.Range("E6").Value = "XX", 1, .Range("E6").Value = "YY", 2)

                  End If

               End If

         End Select

      End With

   Next lngC

End Sub

Gruß Uwe

[Werner.M]

Hallo,

Code:

Option Explicit

Sub prcDrucken()
Dim lngC As Long

For lngC = 2 To 39
   With Worksheets(lngC)
      Select Case lngC
         Case 2 To 4
            With .PageSetup
               .Orientation = xlPortrait
               .FitToPagesWide = 1
               .Zoom = False
               .PrintArea = "$A$1:$E$49"
            End With
            .PrintOut Copies:=1
         Case 5 To 39
            If UCase(.Range("E6").Value) = "XX" Then
               With .PageSetup
                  .Orientation = xlPortrait
                  .FitToPagesWide = 1
                  .Zoom = False
                  .PrintArea = "$A$100:$E$151"
               End With
               .PrintOut Copies:=1
            End If
            If UCase(.Range("E6").Value) = "YY" Then
                With .PageSetup
                    .Orientation = xlPortrait
                    .FitToPagesWide = 1
                    .Zoom = False
                    .PageSetup.PrintArea = "$A$100:$E$151"
                End With
               .PrintOut Copies:=2
            End If
      End Select
   End With
Next lngC

End Sub

Gruß Werner

[Stoffo]

Moin, erstmal vielen Dank ihr zwei.

Die Lösung von Uwe hat auf anhieb das Ergebnis geliefert das ich haben wollte. Werners werde ich bei Gelegenheit auch mal ausprobieren.

Auch vielen Dank für die schnelle Antwort :15: