Zu viele Seiten beim Drucken

Sub Exportdatei_Formatieren()
'Fragen verhindern, Bildschirmakualisierung aus
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Umbenennen und Speichern
Worksheets("Deckblatt").Activate
Range("D2").Select
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(RC[-2],""_"",R[2]C[-2],"" "",R[3]C[-2],"" "",R[1]C[-2],"".xlsx"")"
Dim strPfad As String
Dim DatNam As String
DatNam = Range("D2")
strPfad = Environ("UserProfile") & "\Documents\"
ActiveWorkbook.SaveAs Filename:=strPfad & DatNam, FileFormat _
:=xlOpenXMLWorkbook, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
Worksheets("Ausstattung TGM").Activate
'überflüssige Tabellenblätter Löschen
Worksheets("Tabelle1").Delete
Worksheets("Tabelle2").Delete
Worksheets("Tabelle3").Delete
Worksheets("Mängelliste").Delete
Worksheets("Ausstattung IGM").Delete
'Überschriften und Inhalt Anpassen
Range("Z1").Value = "Bemerkungen"
Dim RaBereich As Range, RaZelle As Range
Set RaBereich = Range("A:A")
Set RaBereich = Intersect(RaBereich, Range("A:A"))
If Not RaBereich Is Nothing Then
For Each RaZelle In RaBereich
RaZelle = Left(RaZelle.Value, 10)
RaZelle = Right(RaZelle.Value, 2)
Next RaZelle
End If
Set RaBereich = Nothing
Dim i As Integer
For i = 1 To 10000
Select Case Cells(i, 1)
Case "1"
Cells(i, 1).Value = "01 - " & Worksheets("Deckblatt").Range("A10")
Case "2"
Cells(i, 1).Value = "02 - " & Worksheets("Deckblatt").Range("A11")
Case "3"
Cells(i, 1).Value = "03 - " & Worksheets("Deckblatt").Range("A12")
Case "4"
Cells(i, 1).Value = "04 - " & Worksheets("Deckblatt").Range("A13")
Case "5"
Cells(i, 1).Value = "05 - " & Worksheets("Deckblatt").Range("A14")
Case "6"
Cells(i, 1).Value = "06 - " & Worksheets("Deckblatt").Range("A15")
Case "7"
Cells(i, 1).Value = "07 - " & Worksheets("Deckblatt").Range("A16")
Case "8"
Cells(i, 1).Value = "08 - " & Worksheets("Deckblatt").Range("A17")
Case "9"
Cells(i, 1).Value = "09 - " & Worksheets("Deckblatt").Range("A18")
Case "10"
Cells(i, 1).Value = "10 - " & Worksheets("Deckblatt").Range("A19")
End Select
Next i
Range("A1").Value = "Gebäudeteil"
'Spalten auswählen und löschen
Set Bereich = Union(Columns(2), Columns(3), Columns(8), Columns(13), Columns(22), Columns(23),   _
_
_
_
_
Columns(24), Columns(25))
Bereich.Delete
'Schriftart etc.
Cells.Select
With Selection.Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
'Zeilen einfärben
Dim z As Integer, farbe As Integer
For z = 1 To 10000
Select Case Cells(z, 6)
Case "0"
farbe = 15
Case Else
farbe = xlNone
End Select
With Rows(z)
.Interior.ColorIndex = farbe
End With
With Cells(z, 6)
.Font.ColorIndex = farbe
End With
With Cells(z, 7)
.Font.ColorIndex = farbe
End With
Next z
Dim x As Integer, Schriftfarbe As Integer
For x = 1 To 10000
Select Case Cells(x, 6)
Case "0"
Schriftfarbe = xlNone
Case Else
Schriftfarbe = 2
End Select
With Cells(x, 5)
.Font.ColorIndex = Schriftfarbe
End With
Next x
'Tabelle_erstellen
Dim objSheet As Worksheet
Set objSheet = ActiveSheet
Dim actRange As Range
Set actRange = objSheet.UsedRange
With objSheet
.ListObjects.Add(xlSrcRange, actRange, , xlYes).Name = "Ausstattung TGM"
.ListObjects("Ausstattung TGM").TableStyle = ""
End With
'Drucklayout festlegen
Cells.EntireColumn.AutoFit
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintArea = "A:Q"
.PrintTitleRows = "$1:$1"
.CenterHeader = Worksheets("Deckblatt").Range("D2") & vbLf & "Ausstattung TGM"
.PrintQuality = 600
.Orientation = xlLandscape
.PaperSize = xlPaperA3
.FitToPagesWide = 1
End With
Application.PrintCommunication = True
'letztes überflüssiges Tabellenblatt löschen
Worksheets("Deckblatt").Delete
'Löschen aller unnötigen Zellen
Dim intRow As Integer, intLastRow As Integer
intLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
For intRow = intLastRow To 1 Step -1
If Application.CountA(Rows(intRow)) = 0 Then
intLastRow = intLastRow - 1
Else
Exit For
End If
Next intRow
For intRow = intLastRow To 1 Step -1
If IsEmpty(Cells(intRow, 1)) Then
Rows(intRow).Delete
End If
Next intRow
'Speichern
Range("A1").Select
ActiveWorkbook.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub