"IgnorePrintAreas:=False" --- trying to get the equivalent when saving excel to excel, anyone help?

Jmorrison67

Board Regular
Joined
Aug 20, 2021
Messages
51
Office Version
  1. 2016
Platform
  1. Windows
Good afternoon Community,

I am looking for help on how to save the print area's when copying worksheets to a new workbook (excel to excel). User Akuini has helped tremendously to get the code I need to where it is now.
I am currently using this parameter when saving worksheets to pdf >
VBA Code:
IgnorePrintAreas:=False
and works as expected for pdf, but I also need to adapt the excel equivalent code which Akuini helped with so that I only save the print area's in the new excel workbook.

Bit about the file I am using:
Workbook has 95 tabs
All worksheets have different Print Area ranges as all contain different tables of info and graphs
I use the whole workbook to pull out different worksheets for different managers to see different info
Each manager (8 or so) gets a combination of different worksheets, with most any one manager gets is 35 worksheets.
There is just as much data outside the print area's, so it is essential the managers only see the print area data

This is the output bit of the code:

VBA Code:
Sheets(ary).Copy
For Each ws In ActiveWorkbook.Worksheets
    With ws.UsedRange
        .Value = .Value
    End With
Next ws

With ActiveWorkbook
    .SaveAs Filename:=FolderPath & " - " & Format(Now, "dd-mm-yyyy hhmm") & ".xlsx"
    .Close
End With

MsgBox "Excel file has been successfully exported."

End Sub


Can anyone help in getting the 'print areas' bit added to the code for when I have to save these down as excel workbooks?

KR
Jmorrison67
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,908
Office Version
  1. 2007
Platform
  1. Windows
Try this:

Put your data in these lines
Rich (BB code):
  ary = Array("Sheet1", "Sheet2", "Sheet3")
  FolderPath = "C:\trabajo\report"


VBA Code:
Sub Macro3()
  Dim wb As Workbook
  Dim sh As Worksheet
  Dim ary As Variant, itm As Variant
  Dim pArea As String, FolderPath As String
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  ary = Array("Sheet1", "Sheet2", "Sheet3")
  FolderPath = "C:\trabajo\report"
  
  Set wb = Workbooks.Add(xlWBATWorksheet)
  wb.Sheets(1).Name = "todelete"
  
  For Each itm In ary
    Set sh = ThisWorkbook.Sheets(itm)
    wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count)).Name = sh.Name
    pArea = sh.PageSetup.PrintArea
    If pArea = "" Then
      sh.UsedRange.Copy
    Else
      sh.Range(pArea).Copy
    End If
    With wb.Sheets(Sheets.Count).Range("A1")
      .PasteSpecial xlPasteValues
      .PasteSpecial xlPasteFormats
      .PasteSpecial xlPasteColumnWidths
    End With
  Next

  wb.Sheets(1).Delete
  wb.SaveAs FileName:=FolderPath & " - " & Format(Now, "dd-mm-yyyy hhmm") & ".xlsx"
  wb.Close False

  MsgBox "Excel file has been successfully exported."
End Sub
 

Jmorrison67

Board Regular
Joined
Aug 20, 2021
Messages
51
Office Version
  1. 2016
Platform
  1. Windows
Thanks - let me give it a try
I had replied before thinking it through, so have edited my reply.
I will revert asap
 

Jmorrison67

Board Regular
Joined
Aug 20, 2021
Messages
51
Office Version
  1. 2016
Platform
  1. Windows
Try this:

Put your data in these lines
Rich (BB code):
  ary = Array("Sheet1", "Sheet2", "Sheet3")
  FolderPath = "C:\trabajo\report"


VBA Code:
Sub Macro3()
  Dim wb As Workbook
  Dim sh As Worksheet
  Dim ary As Variant, itm As Variant
  Dim pArea As String, FolderPath As String
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  ary = Array("Sheet1", "Sheet2", "Sheet3")
  FolderPath = "C:\trabajo\report"
 
  Set wb = Workbooks.Add(xlWBATWorksheet)
  wb.Sheets(1).Name = "todelete"
 
  For Each itm In ary
    Set sh = ThisWorkbook.Sheets(itm)
    wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count)).Name = sh.Name
    pArea = sh.PageSetup.PrintArea
    If pArea = "" Then
      sh.UsedRange.Copy
    Else
      sh.Range(pArea).Copy
    End If
    With wb.Sheets(Sheets.Count).Range("A1")
      .PasteSpecial xlPasteValues
      .PasteSpecial xlPasteFormats
      .PasteSpecial xlPasteColumnWidths
    End With
  Next

  wb.Sheets(1).Delete
  wb.SaveAs FileName:=FolderPath & " - " & Format(Now, "dd-mm-yyyy hhmm") & ".xlsx"
  wb.Close False

  MsgBox "Excel file has been successfully exported."
End Sub
Hola,

This is almost there I think.
Each of the worksheets has graphs and images on them which I would also like to bring over.
I tested it on 4 worksheets; a cover page which has text and 2 images, Contents page which has list of contents and 1 image and two pages which both contain graphs. The above excluded the images and graphs.
Could you amend the code to bring those in at all?

Also is is possible to retain some of the formatting features in the original? For example I have taken the gridlines off the original worksheets
1633521566960.png


Muchas Gracias
Jmorrison67
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,908
Office Version
  1. 2007
Platform
  1. Windows

ADVERTISEMENT

Try the following code, it is closer to your first code.

VBA Code:
Sub Macro1()
  Dim ws As Worksheet
  Dim ary As Variant
  Dim FolderPath As String
  Dim rws As Range, col As Range, rng As Range
  Dim obj As Variant
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  ary = Array("Sheet1", "Sheet2", "Sheet3")
  FolderPath = "C:\trabajo\report"

  Sheets(ary).Copy
  For Each ws In ActiveWorkbook.Worksheets
    Set rng = ws.Range(ws.PageSetup.PrintArea)
    With ws.UsedRange
      .Value = .Value
      For Each col In .Columns
        If Intersect(col, rng) Is Nothing Then
          col.EntireColumn.Clear
        End If
      Next
      For Each rws In .Rows
        If Intersect(rws, rng) Is Nothing Then
          rws.EntireRow.Clear
        End If
      Next
      On Error Resume Next
      For Each obj In ws.DrawingObjects
        If Intersect(obj.TopLeftCell, rng) Is Nothing And _
           Intersect(obj.BottomRightCell, rng) Is Nothing Then
            obj.Delete
        End If
      Next
      For Each obj In ws.Shapes
        If Intersect(obj.TopLeftCell, rng) Is Nothing And _
           Intersect(obj.BottomRightCell, rng) Is Nothing Then
            obj.Delete
        End If
      Next
      On Error GoTo 0
    End With
  Next ws
  
  With ActiveWorkbook
    .SaveAs FileName:=FolderPath & " - " & Format(Now, "dd-mm-yyyy hhmm") & ".xlsx"
    .Close
  End With
  
  MsgBox "Excel file has been successfully exported."
End Sub
 

Jmorrison67

Board Regular
Joined
Aug 20, 2021
Messages
51
Office Version
  1. 2016
Platform
  1. Windows
Try the following code, it is closer to your first code.

VBA Code:
Sub Macro1()
  Dim ws As Worksheet
  Dim ary As Variant
  Dim FolderPath As String
  Dim rws As Range, col As Range, rng As Range
  Dim obj As Variant
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  ary = Array("Sheet1", "Sheet2", "Sheet3")
  FolderPath = "C:\trabajo\report"

  Sheets(ary).Copy
  For Each ws In ActiveWorkbook.Worksheets
    Set rng = ws.Range(ws.PageSetup.PrintArea)
    With ws.UsedRange
      .Value = .Value
      For Each col In .Columns
        If Intersect(col, rng) Is Nothing Then
          col.EntireColumn.Clear
        End If
      Next
      For Each rws In .Rows
        If Intersect(rws, rng) Is Nothing Then
          rws.EntireRow.Clear
        End If
      Next
      On Error Resume Next
      For Each obj In ws.DrawingObjects
        If Intersect(obj.TopLeftCell, rng) Is Nothing And _
           Intersect(obj.BottomRightCell, rng) Is Nothing Then
            obj.Delete
        End If
      Next
      For Each obj In ws.Shapes
        If Intersect(obj.TopLeftCell, rng) Is Nothing And _
           Intersect(obj.BottomRightCell, rng) Is Nothing Then
            obj.Delete
        End If
      Next
      On Error GoTo 0
    End With
  Next ws
 
  With ActiveWorkbook
    .SaveAs FileName:=FolderPath & " - " & Format(Now, "dd-mm-yyyy hhmm") & ".xlsx"
    .Close
  End With
 
  MsgBox "Excel file has been successfully exported."
End Sub
Hola Dante,

I get this:

1633533127657.png


1633533161364.png


There is alot of merged cells in this workbook - so on the 4 tabs I tested changing the formatting from merged cells to 'Centre across selection' in the print area's but didn't seem to help.


1633533720013.png



Any idea's?

KR
Jmorrison67
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,908
Office Version
  1. 2007
Platform
  1. Windows

ADVERTISEMENT

Try this:

VBA Code:
Sub Macro1()
  Dim ws As Worksheet
  Dim ary As Variant
  Dim FolderPath As String
  Dim rws As Range, col As Range, rng As Range
  Dim obj As Variant
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  ary = Array("Sheet1", "Sheet2", "Sheet3")
  FolderPath = "C:\trabajo\report"

  Sheets(ary).Copy
  For Each ws In ActiveWorkbook.Worksheets
    Set rng = ws.Range(ws.PageSetup.PrintArea)
    With ws.UsedRange
      .Value = .Value
      On Error Resume Next
      For Each col In .Columns
        If Intersect(col, rng) Is Nothing Then
          col.EntireColumn.UnMerge
          col.EntireColumn.Clear
        End If
      Next
      For Each rws In .Rows
        If Intersect(rws, rng) Is Nothing Then
          rws.EntireRow.Clear
        End If
      Next
      For Each obj In ws.DrawingObjects
        If Intersect(obj.TopLeftCell, rng) Is Nothing And _
           Intersect(obj.BottomRightCell, rng) Is Nothing Then
            obj.Delete
        End If
      Next
      For Each obj In ws.Shapes
        If Intersect(obj.TopLeftCell, rng) Is Nothing And _
           Intersect(obj.BottomRightCell, rng) Is Nothing Then
            obj.Delete
        End If
      Next
      On Error GoTo 0
    End With
  Next ws
  
  With ActiveWorkbook
    .SaveAs FileName:=FolderPath & " - " & Format(Now, "dd-mm-yyyy hhmm") & ".xlsx"
    .Close
  End With
  
  MsgBox "Excel file has been successfully exported."
End Sub
 
Solution

Jmorrison67

Board Regular
Joined
Aug 20, 2021
Messages
51
Office Version
  1. 2016
Platform
  1. Windows
Try this:

VBA Code:
Sub Macro1()
  Dim ws As Worksheet
  Dim ary As Variant
  Dim FolderPath As String
  Dim rws As Range, col As Range, rng As Range
  Dim obj As Variant
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  ary = Array("Sheet1", "Sheet2", "Sheet3")
  FolderPath = "C:\trabajo\report"

  Sheets(ary).Copy
  For Each ws In ActiveWorkbook.Worksheets
    Set rng = ws.Range(ws.PageSetup.PrintArea)
    With ws.UsedRange
      .Value = .Value
      On Error Resume Next
      For Each col In .Columns
        If Intersect(col, rng) Is Nothing Then
          col.EntireColumn.UnMerge
          col.EntireColumn.Clear
        End If
      Next
      For Each rws In .Rows
        If Intersect(rws, rng) Is Nothing Then
          rws.EntireRow.Clear
        End If
      Next
      For Each obj In ws.DrawingObjects
        If Intersect(obj.TopLeftCell, rng) Is Nothing And _
           Intersect(obj.BottomRightCell, rng) Is Nothing Then
            obj.Delete
        End If
      Next
      For Each obj In ws.Shapes
        If Intersect(obj.TopLeftCell, rng) Is Nothing And _
           Intersect(obj.BottomRightCell, rng) Is Nothing Then
            obj.Delete
        End If
      Next
      On Error GoTo 0
    End With
  Next ws
 
  With ActiveWorkbook
    .SaveAs FileName:=FolderPath & " - " & Format(Now, "dd-mm-yyyy hhmm") & ".xlsx"
    .Close
  End With
 
  MsgBox "Excel file has been successfully exported."
End Sub

[/QUOTE]
Perfect
Muchas Gracias
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,908
Office Version
  1. 2007
Platform
  1. Windows
Im glad to help you. Gracias por comentar.
 

Jmorrison67

Board Regular
Joined
Aug 20, 2021
Messages
51
Office Version
  1. 2016
Platform
  1. Windows
Perfect
Muchas Gracias
Good afternoon Dante,

I hope you're well

I am now using the code to pull out ad hoc reporting for various managers, but today when i tried to run the code using 4 tabs, it seems to freeze when trying to export one of the tabs. I have entered the array of all 4 tabs into the code and it falls over. When i enter the tabs individually into the code to identify which worksheet it is causing the problem, i can pinpoint it to the 3rd one. There is no specific error coming up, it just takes forever to run and infact doesnt actually ever finish running, i have to crash it to get my computer back :(

In this bit:
VBA Code:
 ary = Array("Sheet1", "Sheet2", "Sheet3")

I'm changing it to be the worksheets i need, so in my example this would be:

VBA Code:
ary = Array("Global Volume Site", "Global SNP - NDS", "Global Overheads", "Working Capital")

It seems to freeze at the 3rd worksheet "Global Overheads" - i dont think it is anything to do with the naming of it, but maybe something specific on that worksheet that isnt on the others? As i said there is no specific errors coming up it just doesnt seem to run, just get the blue circle of death and macro says at top "running". When i take out that 3rd one, it runs in 5 secs no problem.

I have removed all the data but kept the templates for each - see attached Dummy Doc (i tried to attach the excel file but there is no option to, is there a way i can send you the file?). I have tried running the macro on the dummy doc and again freezes on the 3rd tab, if remove 3rd one runs fine.

Print area is within the blue dots - this is the 3rd tab which it freezes on:
1634732657564.png


Maybe you might have seen this before?

Kind regards
Jmorrison67
 

Forum statistics

Threads
1,147,482
Messages
5,741,409
Members
423,658
Latest member
Kumaradas

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