Hello,
We in our group have to deal with soffisticated excels the GMP environment requires to print these excel sheets out also using formula view. This is quite a time consuming work. Therefore I have tried to wrtie a macro with chatgpt that helps to adjust the page for printing aoutomatically. So the first part translates the sheet into formula view, adjusts the column width automatically so that no formula is cut off, sets the printing area to the last used row and cell as well as implements headers and lines. This works surprizingly well:
Sub ShowFormulasAndAutoFitWithPrintAreaAndHeaders()
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
On Error GoTo ErrorHandler ' Set up error handling
' 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
' Check if UsedRange is valid and has content
If Not ws.UsedRange Is Nothing Then
' Initialize min and max values
minRow = ws.Rows.Count
maxRow = 1
minCol = ws.Columns.Count
maxCol = 1
' Use an array to check cells in the used range for formatting
cellData = ws.UsedRange.Value
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
If minRow <= maxRow And minCol <= maxCol Then
Set printRange = ws.Range(ws.Cells(minRow, minCol), ws.Cells(maxRow, maxCol))
ws.PageSetup.PrintArea = printRange.Address
Else
' If no valid print area found, set to empty range
ws.PageSetup.PrintArea = ""
End If
' Configure page setup to include headers, gridlines, and print settings
With ws.PageSetup
.PrintGridlines = True ' Print gridlines
.PrintHeadings = True ' Print row and column headings
.Orientation = xlPortrait ' or xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = False ' Adjust as needed
End With
End If
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, print area set, and headers included.", vbInformation
Exit Sub ' Exit before hitting the error handler
ErrorHandler:
' Restore default settings in case of error
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "An error occurred: " & Err.Description, vbExclamation
End Sub
Now comes the tricky part. i want the macro to go for each sheet and prepare it for printing. The logic should be fir the content to a din A4 page and scale down from 100% to 50% by looking if the content fits into the page or not. IF not than switch from portrait to landscape and repeate. If not than create two pages and go back to 100% and distribute the content evently to the two pages, if not than scale down to 95%, 90%...50%, if that does not work create three pages and distribute the content evenly 33% for each page. This however doe not work properly. Chatgpt is not able to create a logic that works. The pages are scaled to max view and often one column is displayed per page:
Sub OptimizeScaleAndDistributeSheets()
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 numPagesWide As Integer
Dim numPagesTall As Integer
Dim bestScale As Double
Dim scalePercent As Double
Dim scaleList As Variant
Dim scaleIndex As Integer
Dim portraitPageWidth As Double
Dim portraitPageHeight As Double
Dim landscapePageWidth As Double
Dim landscapePageHeight As Double
Dim currentOrientation As XlPageOrientation
Dim fitFound As Boolean
Dim totalPages As Integer
Dim maxPages As Integer
Dim rowsPerPage As Long
Dim colsPerPage As Long
Dim lastRow As Long
Dim lastCol As Long
' DIN A4 dimensions in points
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
bestScale = 100
currentOrientation = ws.PageSetup.Orientation
fitFound = False
' Try fitting the content on pages from 1 to N
For Each orientation In Array(xlPortrait, xlLandscape)
ws.PageSetup.Orientation = orientation
If orientation = xlPortrait Then
pageWidth = portraitPageWidth
pageHeight = portraitPageHeight
Else
pageWidth = landscapePageWidth
pageHeight = landscapePageHeight
End If
For scaleIndex = LBound(scaleList) To UBound(scaleList)
scalePercent = scaleList(scaleIndex)
If scalePercent < 50 Then Exit For ' Do not go below 50%
ws.PageSetup.Zoom = scalePercent
numPagesWide = Application.WorksheetFunction.RoundUp(contentWidth * (scalePercent / 100) / pageWidth, 0)
numPagesTall = Application.WorksheetFunction.RoundUp(contentHeight * (scalePercent / 100) / pageHeight, 0)
totalPages = numPagesWide * numPagesTall
If totalPages <= 1 Then
bestScale = scalePercent
currentOrientation = orientation
fitFound = True
Exit For
End If
Next scaleIndex
If fitFound Then Exit For
Next orientation
' Apply the best scale and orientation
ws.PageSetup.Zoom = bestScale
ws.PageSetup.Orientation = currentOrientation
' If more than one page, distribute content evenly across pages
If totalPages > 1 Then
ws.PageSetup.Zoom = False
ws.PageSetup.FitToPagesWide = numPagesWide
ws.PageSetup.FitToPagesTall = numPagesTall
' Adjust the fit to distribute the content evenly
If currentOrientation = xlPortrait Then
rowsPerPage = Application.WorksheetFunction.RoundUp(printArea.Rows.Count / numPagesTall, 0)
colsPerPage = Application.WorksheetFunction.RoundUp(printArea.Columns.Count / numPagesWide, 0)
Else
rowsPerPage = Application.WorksheetFunction.RoundUp(printArea.Rows.Count / numPagesWide, 0)
colsPerPage = Application.WorksheetFunction.RoundUp(printArea.Columns.Count / numPagesTall, 0)
End If
lastRow = printArea.Rows.Count
lastCol = printArea.Columns.Count
For i = 1 To numPagesTall
For j = 1 To numPagesWide
ws.PageSetup.PrintArea = ws.Range(ws.Cells((i - 1) * rowsPerPage + 1, (j - 1) * colsPerPage + 1), _
ws.Cells(Application.Min(i * rowsPerPage, lastRow), Application.Min(j * colsPerPage, lastCol))).Address
Next j
Next i
End If
' Notify user
Debug.Print "Sheet '" & ws.Name & "' optimized to " & totalPages & " pages with scale " & bestScale & "% in " & IIf(currentOrientation = xlPortrait, "portrait", "landscape") & " orientation."
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 optimizations are complete for all sheets.", vbInformation
End Sub
Any ideas how to improove the code?
Regards
Aurum
We in our group have to deal with soffisticated excels the GMP environment requires to print these excel sheets out also using formula view. This is quite a time consuming work. Therefore I have tried to wrtie a macro with chatgpt that helps to adjust the page for printing aoutomatically. So the first part translates the sheet into formula view, adjusts the column width automatically so that no formula is cut off, sets the printing area to the last used row and cell as well as implements headers and lines. This works surprizingly well:
Sub ShowFormulasAndAutoFitWithPrintAreaAndHeaders()
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
On Error GoTo ErrorHandler ' Set up error handling
' 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
' Check if UsedRange is valid and has content
If Not ws.UsedRange Is Nothing Then
' Initialize min and max values
minRow = ws.Rows.Count
maxRow = 1
minCol = ws.Columns.Count
maxCol = 1
' Use an array to check cells in the used range for formatting
cellData = ws.UsedRange.Value
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
If minRow <= maxRow And minCol <= maxCol Then
Set printRange = ws.Range(ws.Cells(minRow, minCol), ws.Cells(maxRow, maxCol))
ws.PageSetup.PrintArea = printRange.Address
Else
' If no valid print area found, set to empty range
ws.PageSetup.PrintArea = ""
End If
' Configure page setup to include headers, gridlines, and print settings
With ws.PageSetup
.PrintGridlines = True ' Print gridlines
.PrintHeadings = True ' Print row and column headings
.Orientation = xlPortrait ' or xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = False ' Adjust as needed
End With
End If
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, print area set, and headers included.", vbInformation
Exit Sub ' Exit before hitting the error handler
ErrorHandler:
' Restore default settings in case of error
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "An error occurred: " & Err.Description, vbExclamation
End Sub
Now comes the tricky part. i want the macro to go for each sheet and prepare it for printing. The logic should be fir the content to a din A4 page and scale down from 100% to 50% by looking if the content fits into the page or not. IF not than switch from portrait to landscape and repeate. If not than create two pages and go back to 100% and distribute the content evently to the two pages, if not than scale down to 95%, 90%...50%, if that does not work create three pages and distribute the content evenly 33% for each page. This however doe not work properly. Chatgpt is not able to create a logic that works. The pages are scaled to max view and often one column is displayed per page:
Sub OptimizeScaleAndDistributeSheets()
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 numPagesWide As Integer
Dim numPagesTall As Integer
Dim bestScale As Double
Dim scalePercent As Double
Dim scaleList As Variant
Dim scaleIndex As Integer
Dim portraitPageWidth As Double
Dim portraitPageHeight As Double
Dim landscapePageWidth As Double
Dim landscapePageHeight As Double
Dim currentOrientation As XlPageOrientation
Dim fitFound As Boolean
Dim totalPages As Integer
Dim maxPages As Integer
Dim rowsPerPage As Long
Dim colsPerPage As Long
Dim lastRow As Long
Dim lastCol As Long
' DIN A4 dimensions in points
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
bestScale = 100
currentOrientation = ws.PageSetup.Orientation
fitFound = False
' Try fitting the content on pages from 1 to N
For Each orientation In Array(xlPortrait, xlLandscape)
ws.PageSetup.Orientation = orientation
If orientation = xlPortrait Then
pageWidth = portraitPageWidth
pageHeight = portraitPageHeight
Else
pageWidth = landscapePageWidth
pageHeight = landscapePageHeight
End If
For scaleIndex = LBound(scaleList) To UBound(scaleList)
scalePercent = scaleList(scaleIndex)
If scalePercent < 50 Then Exit For ' Do not go below 50%
ws.PageSetup.Zoom = scalePercent
numPagesWide = Application.WorksheetFunction.RoundUp(contentWidth * (scalePercent / 100) / pageWidth, 0)
numPagesTall = Application.WorksheetFunction.RoundUp(contentHeight * (scalePercent / 100) / pageHeight, 0)
totalPages = numPagesWide * numPagesTall
If totalPages <= 1 Then
bestScale = scalePercent
currentOrientation = orientation
fitFound = True
Exit For
End If
Next scaleIndex
If fitFound Then Exit For
Next orientation
' Apply the best scale and orientation
ws.PageSetup.Zoom = bestScale
ws.PageSetup.Orientation = currentOrientation
' If more than one page, distribute content evenly across pages
If totalPages > 1 Then
ws.PageSetup.Zoom = False
ws.PageSetup.FitToPagesWide = numPagesWide
ws.PageSetup.FitToPagesTall = numPagesTall
' Adjust the fit to distribute the content evenly
If currentOrientation = xlPortrait Then
rowsPerPage = Application.WorksheetFunction.RoundUp(printArea.Rows.Count / numPagesTall, 0)
colsPerPage = Application.WorksheetFunction.RoundUp(printArea.Columns.Count / numPagesWide, 0)
Else
rowsPerPage = Application.WorksheetFunction.RoundUp(printArea.Rows.Count / numPagesWide, 0)
colsPerPage = Application.WorksheetFunction.RoundUp(printArea.Columns.Count / numPagesTall, 0)
End If
lastRow = printArea.Rows.Count
lastCol = printArea.Columns.Count
For i = 1 To numPagesTall
For j = 1 To numPagesWide
ws.PageSetup.PrintArea = ws.Range(ws.Cells((i - 1) * rowsPerPage + 1, (j - 1) * colsPerPage + 1), _
ws.Cells(Application.Min(i * rowsPerPage, lastRow), Application.Min(j * colsPerPage, lastCol))).Address
Next j
Next i
End If
' Notify user
Debug.Print "Sheet '" & ws.Name & "' optimized to " & totalPages & " pages with scale " & bestScale & "% in " & IIf(currentOrientation = xlPortrait, "portrait", "landscape") & " orientation."
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 optimizations are complete for all sheets.", vbInformation
End Sub
Any ideas how to improove the code?
Regards
Aurum
