Ich habe ein Problem...
Ich habe mir (unter anderem mit der Hilfe vieler toller Beiträge aus diesem Forum) einen Code gebastelt. Er formatiert eine Excel-Tabelle um und legt Druckbereich und -layout fest. Soweit funktioniert auch alles ganz gut, nur wenn ich dann drucken will, sagt er mir es wären 117 Seiten, wobei 115 leer sind...
Kann mir jemand helfen, diese Seiten loszuwerden?
Hier mein Code:
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
Danke schonmal vielmals für die Hilfe:-)
LG Lars
*Ps: bitte nicht an meinem Programmierstil meckern, ich fange grade an VBA zu lernen;-)