Printing range of sheets in excel or in PDF

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.

Code:

---

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.

Hi,

Try this. untested.

Code:

---

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

---

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.

Hi,

Again untested.

Code:

---

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

---

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.

Try

Code:

---

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

---

Hi, Thank you, however, it loops back to this

Code:

---

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.

Can you please attach the workbook ?

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.

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

Hi, the short report is attached.

Hi

Code:

---

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

---

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.

code the copy paste part like this

Code:

---

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

---

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

Sorry.

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

Code:

---

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

---

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

Dears

Any update on this.

Thank you

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://eileenslounge.com/viewtopic.php?p=318868#p318868
https://eileenslounge.com/viewtopic.php?p=318311#p318311
https://eileenslounge.com/viewtopic.php?p=318302#p318302
https://eileenslounge.com/viewtopic.php?p=317704#p317704
https://eileenslounge.com/viewtopic.php?p=317704#p317704
https://eileenslounge.com/viewtopic.php?p=317857#p317857
https://eileenslounge.com/viewtopic.php?p=317541#p317541
https://eileenslounge.com/viewtopic.php?p=317520#p317520
https://eileenslounge.com/viewtopic.php?p=317510#p317510
https://eileenslounge.com/viewtopic.php?p=317547#p317547
https://eileenslounge.com/viewtopic.php?p=317573#p317573
https://eileenslounge.com/viewtopic.php?p=317574#p317574
https://eileenslounge.com/viewtopic.php?p=317582#p317582
https://eileenslounge.com/viewtopic.php?p=317583#p317583
https://eileenslounge.com/viewtopic.php?p=317605#p317605
https://eileenslounge.com/viewtopic.php?p=316935#p316935
https://eileenslounge.com/viewtopic.php?p=317030#p317030
https://eileenslounge.com/viewtopic.php?p=317030#p317030
https://eileenslounge.com/viewtopic.php?p=317014#p317014
https://eileenslounge.com/viewtopic.php?p=316940#p316940
https://eileenslounge.com/viewtopic.php?p=316927#p316927
https://eileenslounge.com/viewtopic.php?p=316875#p316875
https://eileenslounge.com/viewtopic.php?p=316704#p316704
https://eileenslounge.com/viewtopic.php?p=316412#p316412
https://eileenslounge.com/viewtopic.php?p=316412#p316412
https://eileenslounge.com/viewtopic.php?p=316254#p316254
https://eileenslounge.com/viewtopic.php?p=316046#p316046
https://eileenslounge.com/viewtopic.php?p=317050&sid=d7e077e50e904a138c794e1 f2115da95#p317050
https://www.youtube.com/@alanelston2330
https://www.youtube.com/watch?v=yXaYszT11CA&lc=UgxEjo0Di9-9cnl8UnZ4AaABAg.9XYLEH1OwDIA35HNIei0z-
https://eileenslounge.com/viewtopic.php?p=316154#p316154
https://www.youtube.com/watch?v=TW3l7PkSPD4&lc=UgwAL_Jrv7yg7WWC8x14AaABAg
https://teylyn.com/2017/03/21/dollarsigns/#comment-191
https://eileenslounge.com/viewtopic.php?p=317050#p317050
https://eileenslounge.com/viewtopic.php?f=27&t=40953&p=316854#p316854
https://www.eileenslounge.com/viewtopic.php?v=27&t=40953&p=316875#p316875
https://eileenslounge.com/viewtopic.php?p=316057#p316057
https://eileenslounge.com/viewtopic.php?p=315915#p315915
https://eileenslounge.com/viewtopic.php?p=316705#p316705
https://eileenslounge.com/viewtopic.php?p=316704#p316704
https://eileenslounge.com/viewtopic.php?p=176255#p176255
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

Dears

Any updates on this...please.