Change page orientation in another macro

wcd45

New Member
Joined
Jan 28, 2014
Messages
3
I am trying to use a code that I found on this site to put a subtotal on the bottom of my schedules at work. The only problem is that the page needs to print in landscape instead of portrait like this code does. Any help on this would be greatly appreciated.

Sub TestInsertSubtotals()
If Application.International(xlCountrySetting) = 47 Then
If MsgBox("JA, lag en ny arbeidsbok med delsummer nederst på hver side." & Chr(13) & _
"NEI, ikke lag delsummer...", vbYesNo, "Sett inn delsummer nederst på hver side?") = vbNo Then Exit Sub
Else
If MsgBox("YES, create a new workbook with subtotals inserted at the bottom of each page." & Chr(13) & _
"NO, don't insert subtotals...", vbYesNo, "Insert subtotals at the bottom of each page?") = vbNo Then Exit Sub
End If
InsertSubtotals ActiveSheet.UsedRange
End Sub

Sub InsertSubtotals(SourceRange As Range)
' inserts subtotals at the bottom of each page in the active worksheet
' creates a new workbook/worksheet containing the values from the SourceRange in
' the active sheet since the process is not reversible without further programming
Dim TargetWB As Workbook, AWB As String
Dim TotalPageBreaks As Long, pbIndex As Long, pbRow As Long, PreviousPageBreak As Long
Application.ScreenUpdating = False
' create a new workbook/worksheet containing the values from the active sheet
Application.StatusBar = "Creating report workbook..."
AWB = ActiveWorkbook.Name
Set TargetWB = Workbooks.Add
Application.DisplayAlerts = False
While TargetWB.Worksheets.Count > 1
TargetWB.Worksheets(2).Delete
Wend
Application.DisplayAlerts = True
Workbooks(AWB).Activate
SourceRange.Copy
TargetWB.Activate
With Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
' copy the column widths and row heights if necessary
CopyColumnWidths TargetWB.Worksheets(1).Cells, SourceRange
CopyRowHeights TargetWB.Worksheets(1).Cells, SourceRange
' insert subtotals
pbIndex = 0
PreviousPageBreak = 1
TotalPageBreaks = ActiveSheet.HPageBreaks.Count
While pbIndex < TotalPageBreaks
pbIndex = pbIndex + 1
Application.StatusBar = "Inserting subtotal " & pbIndex & " of " & TotalPageBreaks + 1 & " (" & Format(pbIndex / (TotalPageBreaks + 1), "0%") & ")..."
pbRow = GetHPageBreakRow(pbIndex)
If pbRow > 0 Then
InsertSubTotal pbRow, PreviousPageBreak, True, "Page Subtotal:"
PreviousPageBreak = pbRow
TotalPageBreaks = ActiveSheet.HPageBreaks.Count
Else
pbRow = TotalPageBreaks
End If
Wend
' add the last subtotal
Application.StatusBar = "Inserting the last subtotal..."
InsertSubTotal Range("A65536").End(xlUp).Row + 1, PreviousPageBreak, False, "Page Subtotal:"
' add the grand total
Application.StatusBar = "Inserting the grand total..."
InsertSubTotal Range("A65536").End(xlUp).Row + 1, 1, False, "Grand Total:"
Range("A1").Select
Application.StatusBar = False
End Sub

Private Sub InsertSubTotal(RowIndex As Long, PreviousPageBreak As Long, InsertNewRows As Boolean, LabelText As String)
' contains all editing necessary for each subtotal at the bottom of each page
' customization is necessary depending on the subtotals you want to add
Const RowsToInsert As Long = 3
Dim i As Long, TargetRow As Long
TargetRow = RowIndex
If InsertNewRows Then ' not the last subtotal
For i = 1 To RowsToInsert
Rows(RowIndex - RowsToInsert).Insert
Next i
TargetRow = RowIndex - RowsToInsert
End If
If PreviousPageBreak < 1 Then PreviousPageBreak = 1
' insert the necessary subtotal formulas here:
Cells(TargetRow, 1).Formula = LabelText
With Cells(TargetRow, 3)
.Formula = "=subtotal(9,r[-" & TargetRow - PreviousPageBreak & "]c:r[-1]c)"
.NumberFormat = .Offset(-1, 0).NumberFormat
End With
Range(Cells(TargetRow, 1), Cells(TargetRow, 3)).Font.Bold = True
End Sub

Private Function GetHPageBreakRow(PageBreakIndex As Long) As Long
' returns the row number for the given page break, return 0 if the given page break > total page breaks
' uses a temporary name and column in the active sheet to determine the correct page breaks
GetHPageBreakRow = 0
On Error Resume Next
ActiveWorkbook.Names("ASPB").Delete
On Error GoTo 0
ActiveWorkbook.Names.Add "ASPB", "=get.document(64)", False
Columns("A").Insert
Range("A1:A50").FormulaArray = "=transpose(aspb)"
On Error Resume Next
GetHPageBreakRow = Cells(PageBreakIndex, 1).Value
On Error GoTo 0
Columns("A").Delete
ActiveWorkbook.Names("ASPB").Delete
End Function

Private Sub CopyColumnWidths(TargetRange As Range, SourceRange As Range)
Dim c As Long
With SourceRange
For c = 1 To .Columns.Count
TargetRange.Columns(c).ColumnWidth = .Columns(c).ColumnWidth
Next c
End With
End Sub

Private Sub CopyRowHeights(TargetRange As Range, SourceRange As Range)
Dim r As Long
With SourceRange
For r = 1 To .Rows.Count
TargetRange.Rows(r).RowHeight = .Rows(r).RowHeight
Next r
End With
End Sub
 

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,152,260
Messages
5,769,091
Members
425,516
Latest member
Melzebu

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top