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 Formalnsicht 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:

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 den Druckbereich auf eine Seite optimal zu skalieren. Also im idealfall 100% auf eine Seite falls nicht möglihc 95%, 90% unsw. bis ruunter auf 50%. Falls unter 50% dann zwei Seiten machen, falls zwei seiten unter 50% dann 3 Seiten mache nund so weiter...Nun soll es auch den Druckbereich gleich auf mehrere Seiten verteilen also bei 2 Setien 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 unterschrieden. 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?