Using print area to determine first and last column

[jjbungles]

Hello,

I have been trying to use the given print area range and horizontal page breaks to automatically select and copy each page as laid out in page break preview and copy into powerpoint.

I have the peltiertech.com VBA code that does this that once manually selected. I also have VBA code to record the row locations where the HPageBreaks are.

The issue I have is when I ask for the print area like this:

myRange = Sht.PageSetup.PrintArea

the variable myRange is a string and I need to find a way to get the given print area into a format I can reference because right now myRange = "$D$1:£N$556".

Can anyone suggest how I can get obtain the given print area in a usable format, say R1C1, so I can use the first and last columns data in my code?

I did find this example code in the help files under the RefersToRange property, but could not get it to work due to my lack of indepth VBA knowledge.

<CODE>p = Names("Print_Area").[B]RefersToRange[/B].Value
MsgBox "Print_Area: " & UBound(p, 1) & " rows, " & _
    UBound(p, 2) & " columns"</CODE>

Once I figure this out I will share it with the forum for all to use because I think it is a useful Macro to be able to paste a multipage worksheet automatically into PPT.

Thanks,

JJ

 

[pgc01]

Hi JJ

You can display the address in R1C1 notation:

Dim Sht As Worksheet
Dim sPrtRange As String
 
Set Sht = ActiveSheet
 
' get address in A1 notation
sPrtRange = Sht.PageSetup.PrintArea
 
' get address in R1C1 notation
sPrtRange = Range(sPrtRange).Address(ReferenceStyle:=xlR1C1)

 

[jjbungles]

pgc01,

Thank you!

Thank you!!

Thank you!!!!

JJ

 

[pgc01]

JJ, I'm glad it helped. Cheers!

 

[jjbungles]

Hello,

First of all I would like to thank all those people who have helped me over the years and I only wish I could return the favour! Thanks everyone!

I have finished a v0.1 version that works. But since I am a novice it would be nice if some of the senior Mentors here could look at the code and provide me some critique of what I have done.

The way this works is to set the PrintArea and pages breaks in PageBreak Preview to what you want to send to a PPT presentation. It an amalgamation of code available on this site and other so it definitely something that needs to be shared with all. Its one Excel page per PPT slide, it pastes in BitMap and it sizes down to a window within 700W x 400H on a blank slide. The new slides are always appended to the end of the presentation if you have one open, or it opens a new presentation if one is not present.

This still needs some testing for stability / improvements but before I started I thought it would be best if others had a look and critiqued my work - maybe you can find some weak points. I think I did a lot of things the hard way because of my novice skills. Tell me what you think.

And Thanks again pgc01!

JJ

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

and the second one:

Sub ARangeToPresentation()
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim SlideCount As Long
Dim BitMapWidth, BitMapHeight, ScaleRatio As Double
  'Application.ScreenUpdating = False
 
' Make sure a range is selected
If Not TypeName(Selection) = "Range" Then
    MsgBox "Please select a worksheet range and try again.", vbExclamation, _
        "No Range Selected"
Else
    ' Reference instance of PowerPoint
    On Error Resume Next
    ' Check whether PowerPoint is running
    Set PPApp = GetObject(, "PowerPoint.Application")
    If PPApp Is Nothing Then
        ' PowerPoint is not running, create new instance
        Set PPApp = CreateObject("PowerPoint.Application")
        ' For automation to work, PowerPoint must be visible
        PPApp.Visible = True
    End If
    On Error GoTo 0
    ' Reference presentation and slide
    On Error Resume Next
    If PPApp.Windows.Count > 0 Then
        ' There is at least one presentation
        ' Use existing presentation
        Set PPPres = PPApp.ActivePresentation
        ' Use active slide
        Set PPSlide = PPPres.Slides _
            (PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
    Else
        ' There are no presentations
        ' Create new presentation
        Set PPPres = PPApp.Presentations.Add
    End If
    On Error GoTo 0
' Some PowerPoint actions work best in normal slide view
    PPApp.ActiveWindow.ViewType = ppViewSlide
 
    ' Reference active presentation
    Set PPPres = PPApp.ActivePresentation
 
    ' Add a slide
    SlideCount = PPPres.Slides.Count
    Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
    ' Reference active slide
    'Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
    PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
 
    ' Copy the range as a picture
    Selection.CopyPicture Appearance:=xlScreen, _
        Format:=xlBitmap
    ' Paste the range
    PPSlide.Shapes.Paste.Select
 
' Scale down picture to fit in PPT chart
    'Determine width and height
    ScaleRatio = 1 ' Initial Scale ratio
    BitMapWidth = PPApp.ActiveWindow.Selection.ShapeRange.Width
    BitMapHeight = PPApp.ActiveWindow.Selection.ShapeRange.Height
 
    'Test to see which dimension you need to scale down
     If BitMapWidth >= BitMapHeight And BitMapWidth > 700 Then
        ScaleRatio = 700 / BitMapWidth
 
     ElseIf BitMapHeight * ScaleRatio > 400 Then
        ScaleRatio = 400 / BitMapHeight
 
     ElseIf BitMapHeight >= BitMapWidth And BitMapHeight > 400 Then
        ScaleRatio = 400 / BitMapHeight
 
     ElseIf ScaleRatio >= 1 Then
            ScaleRatio = 1
     End If
 
      With PPApp.ActiveWindow.Selection.ShapeRange
        .ScaleWidth ScaleRatio, msoFalse, msoScaleFromTopLeft
        .ScaleHeight ScaleRatio, msoFalse, msoScaleFromTopLeft
    End With
 
  ' Align the pasted range on the presentation slide
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
    ' Clean up
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing
End If
  'Application.ScreenUpdating = True
End Sub

 

[jjbungles]

Found a bug:

   iPBcount = Sht.HPageBreaks.Count

Doesn't seem to count all pagebreaks automatically made by excel, but if you continue to run the macro over and over iPBcount finally gets there.

Any ideas?

JJ

 

[jjbungles]

Hello!

OK I think I got most of the bugs out of this version. Caution: it only does one long vertical column. I havent coded for multiple page columns. That is next.

To solve the accurracy of the page break count:

iPBcount = Sht.HPageBreaks.Count

I had to resort to using:

ActiveWindow.View = xlPageBreakPreview

instead of:

ActiveWindow.DisplayPageBreaks = False

But because I am pasting bitmaps I need to turn off PageBreak Preview and go to normal or the Grey "Page n" shows on every page.

BTW I use bitmap because Pictures sometimes truncates I want to make sure the macro captures what you see.

So here is my updated code:

Option Explicit
Public 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 PageBreak Preview otherwise big gray page numbers show on slides
      ActiveWindow.View = xlPageBreakPreview
'Activate Current Sheet
    Set Sht = ActiveSheet
    Sht.DisplayPageBreaks = True
' get address in A1 notation
    sPrtRange = Sht.PageSetup.PrintArea
 
'Select the print area to determine all the Horiz page breaks
    Sht.Range(sPrtRange).Select
 
'Count only horizontal page breaks and pass to an Integer
    iPBcount = Sht.HPageBreaks.Count
 
' 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
     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
 
    ' Put Excel in PageBreak Preview to find the page breaks
      ActiveWindow.View = xlPageBreakPreview
 
    '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
 
     ' Put Excel in normal view otherwise big gray page numbers show on slides
        ActiveWindow.View = xlNormalView
      ARangeToPresentation ' Call the Powerpoint paste macro
 
        Set rCell1 = Nothing
    Next i
 
  On Error GoTo 0
        Sht.DisplayPageBreaks = False
        Set Sht = Nothing
End Sub

And the PPT Paste from Peltiertech with slight mods:

Private Sub ARangeToPresentation()
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim SlideCount As Long
Dim BitMapWidth, BitMapHeight, ScaleRatio As Double
 
' Make sure a range is selected
    If Not TypeName(Selection) = "Range" Then
        MsgBox "Please select a worksheet range and try again.", vbExclamation, _
            "No Range Selected"
    Else
        ' Reference instance of PowerPoint
        On Error Resume Next
        ' Check whether PowerPoint is running
    If PPApp Is Nothing Then
        ' PowerPoint is not running, create new instance
            Set PPApp = CreateObject("PowerPoint.Application")
        ' For automation to work, PowerPoint must be visible
            PPApp.Visible = True
    End If
 
     Set PPApp = GetObject(, "PowerPoint.Application")
 
   On Error GoTo 0
    ' Reference presentation and slide
    On Error Resume Next
    If PPApp.Windows.Count > 0 Then
        ' There is at least one presentation
        ' Use existing presentation
        Set PPPres = PPApp.ActivePresentation
        ' Use active slide
        Set PPSlide = PPPres.Slides _
            (PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
    Else
        ' There are no presentations
        ' Create new presentation
            Set PPPres = PPApp.Presentations.Add
    End If
    On Error GoTo 0
' Some PowerPoint actions work best in normal slide view
    PPApp.ActiveWindow.ViewType = ppViewSlide
 
    ' Reference active presentation
        Set PPPres = PPApp.ActivePresentation
 
    ' Add a slide at the end
        SlideCount = PPPres.Slides.Count
        Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
 
    ' Go to the slide you just added
        PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
 
    ' Copy the range as a picture
        Selection.CopyPicture Appearance:=xlScreen, _
        Format:=xlBitmap
    ' Paste the range
        PPSlide.Shapes.Paste.Select
 
' Scale down picture to fit in PPT chart PICTURE SET TO FIT INTO 700 WIDE
    ' BY 400 TALL CHANGES THESE NUMBERS TO SUIT
 
    'Determine width and height
        ScaleRatio = 1 ' Initial Scale ratio
        BitMapWidth = PPApp.ActiveWindow.Selection.ShapeRange.Width
        BitMapHeight = PPApp.ActiveWindow.Selection.ShapeRange.Height
 
    'Test to see which dimension you need to scale down
     If BitMapWidth >= BitMapHeight And BitMapWidth > 700 Then
        ScaleRatio = 700 / BitMapWidth
 
     ElseIf BitMapHeight * ScaleRatio > 400 Then
        ScaleRatio = 400 / BitMapHeight
 
     ElseIf BitMapHeight >= BitMapWidth And BitMapHeight > 400 Then
        ScaleRatio = 400 / BitMapHeight
 
     ElseIf ScaleRatio >= 1 Then
            ScaleRatio = 1
     End If
 
      With PPApp.ActiveWindow.Selection.ShapeRange
        .ScaleWidth ScaleRatio, msoFalse, msoScaleFromTopLeft
        .ScaleHeight ScaleRatio, msoFalse, msoScaleFromTopLeft
      End With
 
  ' Align the pasted range on the presentation slide put in the middle for now
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
    ' Clean up
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing
End If
End Sub

As always, if there is a more efficient way of doing this I am all ears!

I would like this routine to occur in the background but when I turn off application updating I dont get any pictures.

Enjoy! And thanks everyone for all your help!

JJ