Hallo,
Auf der Arbeit haben wir sehr Datenlastige Excels die Gedruckt werden müssen. Eine Art des Druckens ist die Formelansicht. Hierbei besonders mühsam ist das Erstellen der Formelansicht bei jedem Sheet und dann das justieren der Zellbreite sowie die Skalierung mind 50% pro Seite. Hinzu kommt Portrait oder Landscape des Blattes. Anschliessend Doppelseitig Drucken. Nun wäre es schön das alles automatisch zu haben. Dies klappt mit Hilfe vcon Chatgpt ganz gut bis zum skalieren Part für den Drucker. Also tatsächlich gibt es mir einen Macro, dass Formelansicht macht und die Zellbreite justiert so dass die Formel nicht zu gross und nicht abgeschnitten ist, ebenfalls legt es den Druckbereich fest auf die letzte benutzte Zelle/Zeile:

Sub ShowFormulasAndAutoFitWithOptimizedPrintArea()
Dim ws As Worksheet
Dim formulaRange As Range
Dim lastRow As Long
Dim lastCol As Long
Dim printRange As Range
Dim minRow As Long
Dim maxRow As Long
Dim minCol As Long
Dim maxCol As Long
Dim rng As Range
Dim cell As Range
Dim cellData As Variant
Dim i As Long, j As Long

Application.ScreenUpdating = False ' Turn off screen updating to speed up the macro
Application.Calculation = xlCalculationManual ' Turn off automatic calculation to speed up the macro

' Loop through all sheets in the workbook
For Each ws In ThisWorkbook.Worksheets
' Define the range where we will place the formulas as text
Set formulaRange = ws.UsedRange

' Iterate through each cell in the used range of the worksheet
For Each cell In formulaRange
' Check if the cell contains a formula
If cell.HasFormula Then
' Display the formula as text in the cell
cell.Value = "'" & cell.Formula
End If
Next cell

' AutoFit columns to adjust for the longest formula in each column
ws.UsedRange.Columns.AutoFit

' Adjust the columns further to remove excessive space
Dim col As Range
For Each col In ws.UsedRange.Columns
col.ColumnWidth = Application.WorksheetFunction.Max(col.ColumnWidth, 15) ' Minimum width for readability
Next col

' Determine the last used row and column efficiently
With ws.UsedRange
lastRow = .Rows(.Rows.Count).Row
lastCol = .Columns(.Columns.Count).Column
End With

' Use an array to check cells in the used range for formatting
cellData = ws.UsedRange.Value
minRow = ws.Rows.Count
maxRow = 1
minCol = ws.Columns.Count
maxCol = 1

For i = LBound(cellData, 1) To UBound(cellData, 1)
For j = LBound(cellData, 2) To UBound(cellData, 2)
If Not IsEmpty(cellData(i, j)) Or _
ws.Cells(i, j).DisplayFormat.Interior.ColorIndex > xlNone Or _
ws.Cells(i, j).DisplayFormat.Borders(xlEdgeBottom).LineStyle > xlNone Then
If i minRow Then minRow = i
If i > maxRow Then maxRow = i
If j minCol Then minCol = j
If j > maxCol Then maxCol = j
End If
Next j
Next i

' Define the print area based on the detected bounding box
Set printRange = ws.Range(ws.Cells(minRow, minCol), ws.Cells(maxRow, maxCol))
ws.PageSetup.PrintArea = printRange.Address

' Optionally set page setup options (e.g., orientation)
With ws.PageSetup
.Orientation = xlPortrait ' or xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = False ' Adjust as needed
End With
Next ws

' Restore default settings
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

' Inform the user that the process is complete
MsgBox "Formulas displayed, columns auto-fitted, and print area set accurately.", vbInformation
End Sub


Nun die Schwierigkeit kommt jetzt auf, den Druckbereich auf eine Seite optimal zu skalieren. Also im Idealfall 100% auf eine Seite falls nicht möglich 95%, 90% unsw. bis runter auf 50%. Falls unter 50% dann zwei Seiten machen, falls zwei Seiten unter 50% dann 3 Seiten machen und so weiter...Nun soll es auch den Druckbereich gleich auf mehrere Seiten verteilen also bei 2 Seiten 50% pro Seite und so weiter bei drei 1/3 so das es nicht dazu kommt dass nur eine Zelle gedruckt wird. Ebenfalls soll es dann checken ob Portrait oder Landscape besser ist. Das ist der schwierige Part, hier bei habe ich es dazu gebracht Portrait oder Landscape gut voneinander zu unterscheiden. Aber die Aufteilung des Druckbereiches auf mehrere Seiten klappt nicht.

Sub ScaleAndDistributeSheets()
Dim ws As Worksheet
Dim printArea As Range
Dim contentWidth As Double
Dim contentHeight As Double
Dim pageWidth As Double
Dim pageHeight As Double
Dim scalePercent As Double
Dim scalingStep As Double
Dim minScale As Double
Dim maxPages As Integer
Dim numPagesWide As Integer
Dim numPagesTall As Integer
Dim totalPages As Integer
Dim currentScale As Double
Dim scaleList As Variant
Dim scaleIndex As Integer
Dim landscapeRequired As Boolean
Dim fitFlag As Boolean
Dim totalPagesRequired As Integer
Dim i As Integer
Dim j As Integer
Dim leftCell As Range
Dim topCell As Range
Dim bottomCell As Range
Dim rightCell As Range

' Define the scaling step and minimum scale percentage
scalingStep = 5 ' Reduce scaling by 5% at a time
minScale = 50 ' Minimum scale percentage
maxPages = 2 ' Start with fitting content to a maximum of 2 pages

' DIN A4 dimensions in points
Dim portraitPageWidth As Double
Dim portraitPageHeight As Double
Dim landscapePageWidth As Double
Dim landscapePageHeight As Double

portraitPageWidth = Application.InchesToPoints(8.27)
portraitPageHeight = Application.InchesToPoints(11.69)
landscapePageWidth = Application.InchesToPoints(11.69)
landscapePageHeight = Application.InchesToPoints(8.27)

' Define scale list for distribution
scaleList = Array(100, 95, 90, 85, 80, 75, 70, 65, 60, 55, 50)

' Loop through each worksheet
For Each ws In ThisWorkbook.Worksheets
On Error Resume Next
If ws.PageSetup.PrintArea > "" Then
Set printArea = ws.Range(ws.PageSetup.PrintArea)
contentWidth = printArea.Width
contentHeight = printArea.Height

fitFlag = False
landscapeRequired = False

' Determine the minimum number of pages required
totalPagesRequired = 1
Do
numPagesWide = Application.WorksheetFunction.Ceiling(contentWidth / IIf(landscapeRequired, landscapePageWidth, portraitPageWidth), 1)
numPagesTall = Application.WorksheetFunction.Ceiling(contentHeight / IIf(landscapeRequired, landscapePageHeight, portraitPageHeight), 1)
totalPages = numPagesWide * numPagesTall

If totalPages > totalPagesRequired Then
totalPagesRequired = totalPagesRequired + 1
Else
Exit Do
End If
Loop

' Try different scales to fit the content
For scaleIndex = LBound(scaleList) To UBound(scaleList)
currentScale = scaleList(scaleIndex)
ws.PageSetup.Zoom = currentScale

If contentWidth * (currentScale / 100) = IIf(landscapeRequired, landscapePageWidth, portraitPageWidth) And _
contentHeight * (currentScale / 100) = IIf(landscapeRequired, landscapePageHeight, portraitPageHeight) Then
fitFlag = True
Exit For
End If
Next scaleIndex

' If content does not fit in portrait mode, switch to landscape orientation
If Not fitFlag Then
landscapeRequired = True
ws.PageSetup.Orientation = xlLandscape

For scaleIndex = LBound(scaleList) To UBound(scaleList)
currentScale = scaleList(scaleIndex)
ws.PageSetup.Zoom = currentScale

If contentWidth * (currentScale / 100) = landscapePageWidth And _
contentHeight * (currentScale / 100) = landscapePageHeight Then
fitFlag = True
Exit For
End If
Next scaleIndex
End If

' If scaling and orientation adjustments are still not fitting, distribute content evenly
If Not fitFlag Then
For scaleIndex = LBound(scaleList) To UBound(scaleList)
currentScale = scaleList(scaleIndex)

numPagesWide = Application.WorksheetFunction.Ceiling(contentWidth / IIf(landscapeRequired, landscapePageWidth, portraitPageWidth), 1)
numPagesTall = Application.WorksheetFunction.Ceiling(contentHeight / IIf(landscapeRequired, landscapePageHeight, portraitPageHeight), 1)
totalPages = numPagesWide * numPagesTall

If totalPages = totalPagesRequired Then
ws.PageSetup.Zoom = False
ws.PageSetup.FitToPagesWide = numPagesWide
ws.PageSetup.FitToPagesTall = numPagesTall
Exit For
End If
Next scaleIndex
End If

' Notify user
Debug.Print "Sheet '" & ws.Name & "' scaling and distribution applied with " & ws.PageSetup.FitToPagesWide & " pages wide and " & ws.PageSetup.FitToPagesTall & " pages tall."
Else
Debug.Print "Sheet '" & ws.Name & "' does not have a print area set."
End If

On Error GoTo 0
Next ws

MsgBox "Scaling and distribution adjustments are complete for all sheets.", vbInformation
End Sub

Habt ihr da eine schlaue Idee wie das gehen könnte?
Grüsse
Aurum