I can not export to PDF, in horizontal format all my range selection, Where am I doing wrong?
Sub Macro()
Dim wksht As Worksheet
Set wksht = ActiveSheet
Dim path As String
path = "C:\test\"
If Len(Dir(path, vbDirectory)) = 0 Then
MkDir path
End If
Dim rngeStart
Dim rngeEnd
Set rngeStart = wksht.UsedRange.Find(What:="####", LookIn:=xlValues, LookAt:=xlWhole)
Set rngeEnd = wksht.UsedRange.FindNext(After:=rngeStart)
Dim dataRange As Range
Set dataRange = wksht.Range(rngeStart, rngeEnd)
Dim wb As Workbook
Dim i As Long
For i = 1 To wksht.Range("A" & wksht.Rows.Count).End(xlUp).Row
wksht.Copy
With ActiveSheet
.Range(.Cells(1, 1), .Cells(1, rngeStart.Column - 1)).EntireColumn.Delete
.Rows("1:" & rngeStart.Row - 1).Delete
End With
This part for Export in PDF, only one page without all range selection:
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=path & wksht.Range("A" & i).Value & ".pdf", _ Quality:=xlQualityStandard,
IncludeDocProperties:=True, IgnorePrintAreas:=False
ActiveWorkbook.Close
Next i
End Sub
is there a function "fit to onepage" export in pdf?
Did you try to adjust the activesheet format before pdf export ?
Please add this code in the begining of your sub Macro() :
'START FORMAT THE ACTIVE SHEET
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape 'xlPortrait
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Application.PrintCommunication = True
'END FORMAT THE ACTIVE SHEET
Related
I have an Excel file which has a button "Generate PDF" that runs a macro to print a certain sheet (lets call it "QUOTE") into a PDF. This sheet is shown to be well limited in margins and in my computer the created PDF has the perfect structure: everything is well included in 1 page. However, in some other computers, when the PDF is created, everything does not fit into 1 page and a 2nd page is created with a bit of content. Here is the code (including the attempts to fix this problem by limiting the margins):
Sub Excel_Export_Proposal()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsCOTIZACION As Worksheet
Dim Proposalname As String
Dim iVis As XlSheetVisibility
Dim xlName As Excel.Name
Dim FolderPath As String
Dim myRange As String
Set wsQUOTE = ThisWorkbook.Sheets("QUOTE")
FolderPath = ActiveWorkbook.Path & "\"
Proposalname = "Quote for " & CStr(Range("B2").Value)
wsQUOTE.PageSetup.PrintArea = myRange
With wsQUOTE.PageSetup
.FitToPagesTall = 1
.FitToPagesWide = False
.Zoom = False
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.4)
.BottomMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(0.75)
End With
'Proposal
Application.ScreenUpdating = False
wb.Unprotect
With wsQUOTE
iVis = .Visible
.Visible = xlSheetVisible
.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=ActiveWorkbook.Path & "\" & Proposalname & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=True, _
OpenAfterPublish:=True
.Visible = iVis
wsQUOTE.Activate
End With
wb.Protect
Application.ScreenUpdating = True
End Sub
Can somebody help me fixing this problem? I would like that the sheet would we printed perfectly regardless of the computer or software in which is generated...
In order to have the procedure Excel_Export_Proposal including the PrintingArea in one page always the following adjustments should be applied:
Set the printing area correctly:
This line sets the printing area: wsQUOTE.PageSetup.PrintArea = myRange
However no value is assigned to the variable myRange before this line, therefore the PrintArea is set to "" which is equivalent to setting it to the entire UsedRange of the wsQUOTE sheet.
To ensure that the entire PrintArea is printed in one page the FitToPagesTall and FitToPagesWide must be set to 1
Replace .FitToPagesWide = False with .FitToPagesWide = 1
And remove .Zoom = False as it has not effect after setting FitToPagesTall and FitToPagesWide to 1
To ensure that the ExportAsFixedFormat method uses the print areas as defined in the target excel file set the IgnorePrintAreas parameter to False.
Replace this line IgnorePrintAreas:=True, _ with this line IgnorePrintAreas:=False, _
Below is the revised procedure:
Sub Excel_Export_Proposal_Revised()
Dim wb As Workbook, wsQuote As Worksheet
Dim myRange As String, Proposalname As String, FolderPath As String
Dim iVis As XlSheetVisibility
Set wb = ThisWorkbook
Set wsQuote = wb.Sheets("QUOTE")
FolderPath = wb.Path & "\"
Proposalname = "Quote for " & wsQuote.Range("B2").Value2
'Update myRange with the address of the range to be printed
myRange = "$B$2:$O$58" 'Change as required
Application.ScreenUpdating = False
With wsQuote.PageSetup
.PrintArea = myRange
.FitToPagesTall = 1
.FitToPagesWide = 1 'Set FitToPagesWide to 1
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.4)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
End With
'Proposal
wb.Unprotect
With wsQuote
iVis = .Visible
.Visible = xlSheetVisible
.Activate
.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=FolderPath & Proposalname & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
.Visible = iVis
End With
wb.Protect
Application.ScreenUpdating = True
End Sub
See following pages for additional information on the resources used:
Worksheet.ExportAsFixedFormat Method (Excel)
PageSetup Object (Excel)
I have the following VBA code saving workbook1 sheets to a folder where workbook1 file is saved. Example: workbook1 has 31 sheets. The code saves each sheet to a new workbook with the same name as the sheet. (Sheet1, Sheet2, etc).
Sub SaveShtsAsBook()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
.Name = SheetName
[A1].Select
End With
'save book in this folder
.SaveAs Filename:=MyFilePath _
& "\" & SheetName & ".xls"
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub
I need to modify the code to save the file with the ID and date. The ID is in cell A1. "XXX Clinic Pro Fees Report for Doe, John (JDOE)". In this example I need the new workbook to save as JDOE_2017-10-20.
Is there a way to gave the ID and place the date after it?
Try the below code
Sub SaveShtsAsBook()
Dim ldate As String
Dim SheetName1 As String
ldate = Format(Now(), "yyyy-mm-dd")
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
SheetName1 = Range(A1).Value2 & ldate
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
.Name = SheetName
[A1].Select
End With
tempstr = Cells(1, 1).Value2
openingParen = InStr(tempstr, "(")
closingParen = InStr(tempstr, ")")
SheetName1 = Mid(tempstr, openingParen + 1, closingParen - openingParen - 1) & "_" & ldate
'save book in this folder
.SaveAs Filename:=MyFilePath _
& "\" & SheetName1 & ".xls"
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub
You can extract the name code from within the brackets and append the date with a couple lines of code.
SheetName = Split(Split(.Cells(1, 1).Value2, "(")(1), ")")(0)
SheetName = sn & Format(Date, "_yyyy-mm-dd")
Along with a couple other modifications as,
Option Explicit
Sub SaveShtsAsBook()
Dim ws As Worksheet, sn As String, mfp As String, n As Long
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
On Error Resume Next '<< a folder exists
mfp = ActiveWorkbook.Path & "\" & Split(ThisWorkbook.Name, Chr(46))(0)
MkDir mfp '<< create a folder
On Error GoTo 0 '<< resume default error handling
With ActiveWorkbook
For n = 1 To .Worksheets.Count
With .Worksheets(n)
sn = Split(Split(.Cells(1, 1).Value2, "(")(1), ")")(0)
sn = sn & Format(Date, "_yyyy-mm-dd")
.Copy
With ActiveWorkbook
'save book in this folder
.SaveAs Filename:=mfp & "\" & sn, FileFormat:=xlExcel8
.Close SaveChanges:=False
End With
End With
Next
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
My code currently opens a file picker and selects files and a particular column im interested in combining into my master worksheet.
I pick several .csv files and bring in a column of my choosing .
Issue I have are,
1) these files are large, 400kb.
2) I get run time error 1004, copy area and paste area are not the same size and shape. Am I just running out of space on my excel sheet? when i debug i get error on line copyRng.Copy destRng
My end goal is to see and count and see the unique values from Col C(perhaps some other columns) from all my workbooks.
Option Explicit
Dim wsMaster As Workbook, csvFiles As Workbook
Dim Filename As String
Dim File As Integer
Dim r As Long
Public Sub Consolidate()
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Title = "Select files to process"
.Show
If .SelectedItems.Count = 0 Then Exit Sub
Set wsMaster = ActiveWorkbook
Dim copyRng As Range, destRng As Range
Dim firstRow As Long
For File = 1 To .SelectedItems.Count
Filename = .SelectedItems.Item(File)
If Right(Filename, 4) = ".csv" Then
Set csvFiles = Workbooks.Open(Filename, 0, True)
r = wsMaster.Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
'' This is the main new part
Set copyRng = csvFiles.Sheets(1).Range("C1:C" & r)
With wsMaster.Sheets("Sheet1")
firstRow = .Cells(.Rows.Count, 2).End(xlUp).Row
Set destRng = .Range("A" & firstRow + 1).Offset(0, 1)
End With
copyRng.Copy destRng
''''''''''
csvFiles.Close SaveChanges:=False 'close without saving
End If
Next File
End With
Set wsMaster = Nothing
Set csvFiles = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Updated code with below recommendation
Option Explicit
Dim wsMaster As Workbook, csvFiles As Workbook
Dim Filename As String
Dim File As Integer
Dim r As Long
Public Sub Consolidate()
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Title = "Select files to process"
.Show
If .SelectedItems.Count = 0 Then Exit Sub
Set wsMaster = ActiveWorkbook
Dim copyRng As Range, destRng As Range
Dim firstRow As Long
For File = 1 To .SelectedItems.Count
Filename = .SelectedItems.Item(File)
If Right(Filename, 4) = ".csv" Then
Set csvFiles = Workbooks.Open(Filename, 0, True)
r = csvFiles.Sheets(1).Range("C" & Rows.Count).End(xlUp).Row
'' This is the main new part
Set copyRng = csvFiles.Sheets(1).Range("C1:C" & r)
With wsMaster.Sheets("Sheet1")
firstRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
Set destRng = .Range("B" & firstRow & "B" & (firstRow + r))
End With
destRng.Value = copyRng.Value
''''''''''
csvFiles.Close SaveChanges:=False 'close without saving
End If
Next File
End With
Set wsMaster = Nothing
Set csvFiles = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Since the number of rows is defined by r you can set the dimensions of the destination range. The change below should fix the copy-paste error and speed up your code by eliminating use of the clipboard (assuming you only want the values to be copied).
If Right(Filename, 4) = ".csv" Then
Set csvFiles = Workbooks.Open(Filename, 0, True)
r = csvFiles.Sheets(1).Range("C" & Rows.Count).End(xlUp).Row
'' This is the main new part
Set copyRng = csvFiles.Sheets(1).Range("C1:C" & r)
With wsMaster.Sheets("Sheet1")
firstRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
Set destRng = .Range("B" & firstRow & ":B" & (firstrow + r))
End With
DestRng.value = CopyRng.value
''''''''''
csvFiles.Close SaveChanges:=False 'close without saving
End If
I wanted to know is there any way to work around this code so that I can import and export named ranges and their values from a workbook to and via .csv file format.
I can successfully import or export the named ranges of single cell. But I get error while exporting the multicell named ranges as they are arrays.
Code for exporting the named ranges to csv is this
Option Explicit
Sub ExportCSV()
Dim ws As Worksheet
Dim str1 As String
Dim i As Long
Dim FinalRow As Long
Set ws = Sheets("Export")
With ws
Application.ScreenUpdating = False
ws.Activate
ws.Range("A1").Select
Selection.ListNames
FinalRow = ws.Range("B9000").End(xlUp).Row
For i = 1 To FinalRow
Cells(i, "B") = Replace(Cells(i, "B"), "$", "")
Next i
Dim fileSaveName As Variant
fileSaveName = Application.GetSaveAsFilename( _
fileFilter:="Excel Files (*.csv), *.csv")
If fileSaveName <> False Then
'Code to save the file
ws.Copy
With ActiveWorkbook
.SaveAs Filename:=fileSaveName, FileFormat:=xlCSV, CreateBackup:=False
.Close False
End With
End If
ws.Cells.Clear
End With
Worksheets("Preferences").Activate
Range("A1").Select
Application.ScreenUpdating = True
MsgBox "Data Exported Successfully at " & vbNewLine & fileSaveName, vbInformation
End Sub
Code for importing named ranges and their values is this
Option Explicit
Sub impdata()
Dim MyCSV As Workbook
Dim MyCSVPath As String
Dim MyRange As Range
Dim MyCell As Range
Dim MyNextCell As Range
Dim MyNamedRange As Range
Dim ws As Worksheet
Dim FinalRow As Long
MyCSVPath = GetFile
If MyCSVPath <> "" Then
Set MyCSV = Workbooks.Open(MyCSVPath)
Application.ScreenUpdating = False
Set ws = Sheets(1)
FinalRow = ws.Range("B90000").End(xlUp).Row
Set MyRange = MyCSV.Worksheets(1).Range("B1" & ":B" & FinalRow)
ThisWorkbook.Activate
For Each MyCell In MyRange.Cells
'Get a reference to the named range.
Set MyNamedRange = Range(ThisWorkbook.Names(MyCell.Offset(, -1).Value))
'Find the next empty cell in the named range.
Set MyNextCell = MyNamedRange.Cells(MyNamedRange.Cells.Count).End(xlUp).Offset(1)
'If the next empty cell is above the named range, then set
'it to the first cell in the range.
If MyNextCell.Row < MyNamedRange.Cells(1).Row Then
Set MyNextCell = MyNamedRange.Cells(1)
End If
'Place the value in the range.
MyNextCell = MyCell.Value
Next MyCell
End If
MyCSV.Close False
Application.ScreenUpdating = True
End Sub
'---------------------------------------------------------------------------------------
' Procedure : GetFile
' Date : 23/10/2015
' Purpose : Returns the full file path of the selected file
' To Use : vFile = GetFile()
'---------------------------------------------------------------------------------------
Function GetFile(Optional startFolder As Variant = -1) As Variant
Dim fle As FileDialog
Dim vItem As Variant
Set fle = Application.FileDialog(msoFileDialogFilePicker)
With fle
.Title = "Select a File"
.AllowMultiSelect = False
.Filters.Add "Comma Separate Values", "*.CSV", 1
If startFolder = -1 Then
.InitialFileName = Application.DefaultFilePath
Else
If Right(startFolder, 1) <> "\" Then
.InitialFileName = startFolder & "\"
Else
.InitialFileName = startFolder
End If
End If
If .Show <> -1 Then GoTo NextCode
vItem = .SelectedItems(1)
End With
NextCode:
GetFile = vItem
Set fle = Nothing
End Function
Export Code
You've put With ws and didn't really use it your code, it'd be safer and also much more practical to do so! ;)
Here is the new export code, it will keep a master file listing your Named Ranges with the value if there is only one cell or the file name (placed in the folder "Save_as_CSV", so that you can find it to re-import it) if there is multiple cells :
Option Explicit
Sub ExportCSV()
Dim Ws As Worksheet, _
WsO As Worksheet, _
Str1 As String, _
i As Long, _
ShName As String, _
RgName As String, _
FileName As String, _
FileFullName As String, _
RgO As Range, _
FinalRow As Long, _
FileSaveName As Variant
Application.ScreenUpdating = False
Set Ws = Sheets("Export")
Set WsO = Sheets("OutPut")
With Ws
.Range("A1").ListNames
FinalRow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 1 To FinalRow
If InStr(1, .Cells(i, "B"), ":") Then
'NamedRange with Multiple cellS
ShName = Replace(Replace(Split(.Cells(i, "B"), "!")(0), "=", ""), "'", "")
RgName = Replace(Split(.Cells(i, "B"), "!")(1), "$", "")
Set RgO = ThisWorkbook.Sheets(ShName).Range(RgName)
WsO.Cells.Clear
WsO.Range("A1").Resize(RgO.Rows.Count, RgO.Columns.Count).Value = RgO.Value
FileName = .Cells(i, "A") & ".csv"
FileFullName = ThisWorkbook.Path & "\Save_as_CSV\" & FileName
'Code to save the file
WsO.Copy
With ActiveWorkbook
.SaveAs FileName:=FileFullName, FileFormat:=xlCSV, CreateBackup:=False
.Close False
End With
.Cells(i, "B") = FileName
Else
'NamedRange with only one cell
.Cells(i, "B") = Replace(.Cells(i, "B"), "$", "")
End If
Next i
FileSaveName = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.csv), *.csv")
If FileSaveName <> False Then
'Code to save the file
.Copy
With ActiveWorkbook
.SaveAs FileName:=FileSaveName, FileFormat:=xlCSV, CreateBackup:=False
.Close False
End With
End If
.Cells.Clear
End With
Worksheets("Preferences").Range("A1").Select
Application.ScreenUpdating = True
MsgBox "Data Exported Successfully at " & vbNewLine & FileSaveName, vbInformation
End Sub
Import Code
MyNextCell = MyCell.Value (I think MyCell.Value is the address of the named range) should be :
MyNextCell.Resize(Range(MyCell.Value).Rows.Count, _
Range(MyCell.Value).Columns.Count).Value = _
Sheets(Names(MyCell.Value).RefersToRange.Parent.Name).Range(MyCell.Value).Value
If you work with CSV, this might be better Set MyCSV = Workbooks.Open(MyCSVPath, Local:=True) than Set MyCSV = Workbooks.Open(MyCSVPath)
If you want to add the data to what you already have (I tilted after that you must be trying only to update it), Set MyNextCell = MyNamedRange.Cells(MyNamedRange.Cells.Count).End(xlUp).Offset(1)
(will start at the end of the named range and go up, then Offset, so it'll give you the second line of the named range)
should be :
Set MyNextCell = MyNamedRange.Cells(MyNamedRange.Cells.Count).Offset(1)
I am completely new to VBA and need to export multiple graphs from an excel workbook to a single pdf using vba. I know it's possible to export the graphs as individual pdf's or jpgs but is it possibly to put all graphs from a workbook into one pdf using vba? Any advice would be greatly appreciated as I can't seem to find what I'm looking for elsewhere.
My code so far prints each chart to the pdf, but each chart gets overwritten on the next print. My code is as follows:
Sub exportGraphs()
Dim Ws As Worksheet
Dim Filename As String
Filename = Application.InputBox("Enter the pdf file name", Type:=2)
Sheets("Status and SLA trends").Select
ActiveSheet.ChartObjects("Chart 4").Activate
ActiveChart.ExportAsFixedFormat xlTypePDF, Filename, xlQualityStandard
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.ExportAsFixedFormat xlTypePDF, Filename, xlQualityStandard
Sheets("Current Issue Status").Select
ActiveSheet.ChartObjects("Chart 2").Activate
ActiveChart.ExportAsFixedFormat xlTypePDF, Filename, xlQualityStandard
ActiveSheet.ChartObjects("Chart 5").Activate
ActiveChart.ExportAsFixedFormat xlTypePDF, Filename, xlQualityStandard
ActiveSheet.ChartObjects("Chart 8").Activate
ActiveChart.ExportAsFixedFormat xlTypePDF, Filename, xlQualityStandard
End Sub
In the end I just exported an array of sheets to pdf, as multiple charts were on separate sheets and I didn't need to change how they were formatted. I did it using the following code snippet
Sheets(Array("Current Issue Status", "Status and SLA trends")).Select
Dim saveLocation As String
saveLocation = Application.GetSaveAsFilename( _
fileFilter:="PDF Files (*.pdf), *.pdf")
If saveLocation <> "False" Then
ActiveSheet.ExportAsFixedFormat xlTypePDF, saveLocation, xlQualityStandard
End If
Is this what you are trying?
LOGIC: Copy all charts to a Temp Sheet and then use the Excel's inbuilt tool to create the pdf. Once the pdf is made, delete the temp sheet. This will export multiple graphs from Sheets("Status and SLA trends") to a single pdf using vba.
CODE (TRIED AND TESTED):
Option Explicit
Sub Sample()
Dim ws As Worksheet, wsTemp As Worksheet
Dim chrt As Shape
Dim tp As Long
Dim NewFileName As String
On Error GoTo Whoa
Application.ScreenUpdating = False
NewFileName = "C:\Charts.Pdf"
Set ws = Sheets("Status and SLA trends")
Set wsTemp = Sheets.Add
tp = 10
With wsTemp
For Each chrt In ws.Shapes
chrt.Copy
wsTemp.Range("A1").PasteSpecial
Selection.Top = tp
Selection.Left = 5
tp = tp + Selection.Height + 50
Next
End With
wsTemp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=NewFileName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
Application.DisplayAlerts = False
wsTemp.Delete
LetsContinue:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
[Export all charts to one PDF] This worked for me: I extended the sample from here . It copies all charts to a temporary sheet, then changes the page setup (letter /landscape) and resize/re-position each chart to fit separate page borders. Last step is to print this sheet as pdf doc and delete temp sheet.
Sub kartinka()
Dim i As Long, j As Long, k As Long
Dim adH As Long
Dim Rng As Range
Dim FilePath As String: FilePath = ThisWorkbook.Path & "\"
Dim sht As Worksheet, shtSource As Worksheet, wk As Worksheet
'===================================================================
'===================================================================
Sheets.Add After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = "ALL"
Set sht = ActiveSheet
'===================================================================
Application.ScreenUpdating = False
'===================================================================
'Excluding ALL tab, copying all charts from all tabs to ALL
For Each wk In Worksheets
If wk.Name <> "ALL" Then
Application.DisplayAlerts = False
j = wk.ChartObjects.Count
For i = 1 To j
wk.ChartObjects(i).Activate
ActiveChart.ChartArea.Copy
sht.Select
ActiveSheet.Paste
sht.Range("A" & 1 + i & "").Select
Next i
Application.DisplayAlerts = True
End If
Next
'===================================================================
'===================================================================
'To set the constant cell vertical increment for separate pages
adH = 40
k = 0
j = sht.ChartObjects.Count
'===================================================================
Application.PrintCommunication = True 'this will allow page settings to update
'To set page margins, adding some info about the file location, tab name and date
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.Orientation = xlLandscape
.LeftHeader = "Date generated : " & Now
.CenterHeader = ""
.RightHeader = "File name : " & ActiveWorkbook.Name
.LeftFooter = "File location : " & FilePath & ThisWorkbook.Name
.CenterFooter = ""
.RightFooter = ""
.FitToPagesWide = 1
End With
'===================================================================
'adjusting page layout borders
sht.VPageBreaks.Add sht.[N1]
For i = 40 To j * 40 Step 40
sht.HPageBreaks.Add Before:=sht.Cells(i + 1, 1)
Next i
Columns("A:A").EntireRow.RowHeight = 12.75
Rows("1:1").EntireColumn.ColumnWidth = 8.43
'===================================================================
For i = 1 To j
Set Rng = ActiveSheet.Range("A" & (1 + k * adH) & " :M" & (40 + k * adH) & "")
With ActiveSheet.ChartObjects(i)
.Height = Rng.Height
.Width = Rng.Width
.Top = Rng.Top
.Left = Rng.Left
End With
ActiveSheet.PageSetup.PrintArea = "$A$1:$M" & (40 + k * adH) & ""
k = k + 1
Next i
'===================================================================
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FilePath & ActiveWorkbook.Name & "." & ActiveSheet.Name, Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
'===================================================================
Application.DisplayAlerts = False
ThisWorkbook.Sheets("ALL").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub