Printing range of sheets in excel or in PDF

[excel_learner]

I have following macro which prints from the ranges defined, but if i want to print the same ranges and save them in one excel file as sheets separately. And also if i want to print the same and save as pdf file.


Sub Print_Ranges()
Dim strShtname As String, strRngName As String
Dim i As Long

With Worksheets("INDEX")

'sort the named range list according to page number order
.Range("A2").CurrentRegion.Sort key1:=Range("A3"), order1:=xlAscending, Header:=xlYes, ordercustom:=1, Orientation:=xlTopToBottom

'loop through the cells and determine parent of named range and specific range addresses
For i = 3 To 38
strRngName = .Cells(i, 2).Text
strShtname = Range(strRngName).Parent.Name

'clear any existing print areas and reset to named ranges areas
With Worksheets(strShtname)
.PageSetup.PrintArea = ""
.PageSetup.PrintArea = Range(strRngName).Address
.PrintOut
' .PrintPreview
End With
Next i
End With

End Sub


Kindly assist.

[Admin]

Hi,

Try this. untested.


Sub Print_Ranges()

Dim strShtname As String, strRngName As String
Dim i As Long, strFileName As String


With Worksheets("INDEX")

'sort the named range list according to page number order
.Range("A2").CurrentRegion.Sort key1:=Range("A3"), order1:=xlAscending, Header:=xlYes, ordercustom:=1, Orientation:=xlTopToBottom

'loop through the cells and determine parent of named range and specific range addresses
For i = 3 To 38
strRngName = .Cells(i, 2).Text
strShtname = Range(strRngName).Parent.Name
strFileName = ThisWorkbook.Path & "\" & strShtname & Format(Date, "mm-dd-yy") & ".pdf"
'clear any existing print areas and reset to named ranges areas
With Worksheets(strShtname)
.PageSetup.PrintArea = ""
.PageSetup.PrintArea = Range(strRngName).Address
.PrintOut
' .PrintPreview

'// Save the print area as a PDF file
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strFileName, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
Next i
End With

End Sub

[excel_learner]

Thanks, I will test this..
Can this code be changed to do this saving in excel file. in fact all the ranges are in named sheet and i want to extract them in same named sheet and save them as flat file without formulas (for circulation) and leaving other sheets where named ranges are not taken in 1 to 38.

I would much appreciate that.

Thanks once again.

[Admin]

Hi,

Again untested.


Sub Print_Ranges()

Dim strShtname As String, strRngName As String
Dim i As Long, strFileName As String
Dim wbkActive As Workbook
Dim wbkPDF As Workbook
Dim wbkNew As Workbook
Dim rngDest As Range
Dim RowsCount As Long

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

Set wbkActive = ThisWorkbook
Set wbkPDF = Workbooks.Add
Set rngDest = wbkPDF.Worksheets(1).Range("a1")

With wbkActive.Worksheets("INDEX")

'sort the named range list according to page number order
.Range("A2").CurrentRegion.Sort key1:=Range("A3"), order1:=xlAscending, Header:=xlYes, ordercustom:=1, Orientation:=xlTopToBottom

'loop through the cells and determine parent of named range and specific range addresses
For i = 3 To 38
strRngName = .Cells(i, 2).Text
strShtname = Range(strRngName).Parent.Name

strFileName = wbkActive.Path & "\" & strShtname & Format(Date, "mm-dd-yy")
'clear any existing print areas and reset to named ranges areas
With wbkActive.Worksheets(strShtname)
.PageSetup.PrintArea = ""
.PageSetup.PrintArea = Range(strRngName).Address

'// Paste the data to the workbook for PDF
.Range(strRngName).Copy rngDest
RowsCount = .Range(strRngName).Rows.Count
Set rngDest = rngDest.Offset(RowsCount)
'// Paste the data to a new workbook
Set wbkNew = Workbooks.Add
.Range(strRngName).Copy wbkNew.Worksheets(1).Range("a1")
'// Save the print area as a new file
wbkNew.SaveAs strFileName, 51
wbkNew.Close
Set wbkNew = Nothing
End With
Next i
End With

wbkPDF.Worksheets(1).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
wbkActive.Path & "\" & Format(Date, "mmmmyy") & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False



End Sub

[excel_learner]

Hi
Sorry for getting back very late on this...however, i am getting run time error "1004" on this line

.Range("A2").CurrentRegion.Sort key1:=Range("A3"), order1:=xlAscending, Header:=xlYes, ordercustom:=1, Orientation:=xlTopToBottom

Kindly advise.

[Admin]

Try


.Range("A2").CurrentRegion.Sort key1:=.Range("A3"), order1:=xlAscending, Header:=xlYes, ordercustom:=1, Orientation:=xlTopToBottom

[excel_learner]

Hi, Thank you, however, it loops back to this
strShtname = .Range(strRngName).Parent.Name and stops there. But it does copy first page in the range and opens new wb and paste it there, but copies with formulas and not with correct page setup.

Please assist.

[Admin]

Can you please attach the workbook ?

[excel_learner]

Hi, Thanks, the file i have after cutting it short, is 1.4 mb, how do i attach it here as it allows only 102kb.

[Admin]

Preserve the format and delete the data before uploading. Also delete unnecessary worksheets.

[excel_learner]

Hi, the short report is attached.

[Admin]

Hi


For i = 3 To 38
strRngName = .Cells(i, 2).Text
If Not ThisWorkbook.Name = ActiveWorkbook.Name Then ThisWorkbook.Activate
strShtname = Range(strRngName).Parent.Name
strFileName = wbkActive.Path & "\" & strShtname & Format(Date, "dd-mm-yy")
'clear any existing print areas and reset to named ranges areas
With wbkActive.Worksheets(strShtname)
.PageSetup.PrintArea = ""
.PageSetup.PrintArea = .Range(strRngName).Address

'// Paste the data to the workbook for PDF
.Range(strRngName).Copy rngDest
RowsCount = .Range(strRngName).Rows.Count
Set rngDest = rngDest.Offset(RowsCount)
'// Paste the data to a new workbook
Set wbkNew = Workbooks.Add
.Range(strRngName).Copy wbkNew.Worksheets(1).Range("a1")
'// Save the print area as a new file
wbkNew.SaveAs strFileName, 51
wbkNew.Close
Set wbkNew = Nothing
End With
Next i

[excel_learner]

Hi, thank you it worked, creates the pdf file but looses print areas and original columns' width and formatting, does not convert the ranges into a separate page. It also create an excel file but with same issue of print areas.

[Admin]

code the copy paste part like this


.Range(strRngName).Copy
rngDest.PasteSpecial xlPasteValues
rngDest.PasteSpecial xlPasteFormats
rngDest.PasteSpecial xlPasteColumnWidths

[excel_learner]

Thanks, however, in which place should i insert these codes.

[Admin]

Sorry.

replace the following lines and paste the above code in procedure 'Print_Rangespdf'


'// Paste the data to the workbook for PDF
.Range(strRngName).Copy rngDest

[excel_learner]

Hi, Admin, Thanks for the advice, however, see the attached file if i have correctly used the codes, as it has same formatting issue.

Please advise and thank you for your cooperation and patience.

Regards

[excel_learner]

Dears

Any update on this.

Thank you

[excel_learner]

Dears

Any updates on this...please.