```
Sub Excel_PageBreak_Preview_to_PowerPoint()
Dim sPrtRange, ULRange, LRRange As String
Dim rCell1 As Range
Dim i, iPBcount, AddressLength, ColonCount As Integer
Dim RightC, LeftC, MinRowPos, MaxRowPos As Integer
Dim Sht As Worksheet
Dim UpperRow As Long
Dim UpperColumn As Long
Dim LowerRow As Long
Dim LowerColumn As Long
' Put Excel in normal view otherwise big gray page numbers show on slides
ActiveWindow.View = xlNormalView
'Activate Current Sheet
Set Sht = ActiveSheet
' get address in A1 notation
sPrtRange = Sht.PageSetup.PrintArea
' get address in R1C1 notation - Thanks to pgc01!
sPrtRange = Range(sPrtRange).Address(ReferenceStyle:=xlR1C1)
' pull print area range apart to sepatate row and column
AddressLength = Len(sPrtRange) 'find out how many characters in string
ColonCount = InStr(1, sPrtRange, ":") 'find out the position of the colon in the string
LeftC = InStr(1, sPrtRange, "C") ' find the position of the first column C
RightC = InStr(ColonCount, sPrtRange, "C") ' find the position of the second column C
ULRange = Left(sPrtRange, ColonCount - 1) 'Extract the Upper cell number
LRRange = Right(sPrtRange, AddressLength - ColonCount) ' Extract the Lower cell number
UpperRow = Mid(sPrtRange, 2, LeftC - 2) ' Extract the most upper row in PrintArea
LowerRow = Mid(sPrtRange, ColonCount + 2, RightC - ColonCount - 2) ' Extract the Lowest Row in PrintArea
UpperColumn = Mid(sPrtRange, LeftC + 1, ColonCount - LeftC - 1) 'Extract left most column in PrintArea
LowerColumn = Mid(sPrtRange, RightC + 1, AddressLength - RightC) 'Extract right most column in PrintArea
'Select the uppermost cell to clear any highlighting
Sht.Range("A1").Select
'Let this work in the background - but does not work on PPT
'Application.ScreenUpdating = False
'Count only horizontal page breaks and pass to an Integer
iPBcount = Sht.HPageBreaks.Count
On Error Resume Next
'Loop as many times as there horizontal page breaks.
For i = 1 To iPBcount + 1 ' Must add one to obtain last page because edge of printarea is not counted in HPageBreaks
'Set variable below row above pagebreak i
Set rCell1 = Sht.HPageBreaks(i).Location.Offset(-1, 0)
'Conditional test if first page, set to most upperleft position
If i = 1 Then
MinRowPos = UpperRow
Else
MinRowPos = MaxRowPos + 1
End If
'Load maximum row position
MaxRowPos = rCell1.Row
If rCell1 Is Nothing Then 'Test if Last page break
Range(Cells(MinRowPos, UpperColumn), Cells(LowerRow, LowerColumn)).Select
Else
Range(Cells(MinRowPos, UpperColumn), Cells(MaxRowPos, LowerColumn)).Select
End If
ARangeToPresentation ' Call the Powerpoint paste macro
Set rCell1 = Nothing
Next i
On Error GoTo 0
Set Sht = Nothing
'Application.ScreenUpdating = True
'Sht.DisplayPageBreaks = False
End Sub
```